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 #include "HsVersions.h"
17 module FloatIn ( floatInwards ) where
25 import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
26 elementOfIdSet, SYN_IE(IdSet), GenId, SYN_IE(Id)
28 import Util ( nOfThem, panic, zipEqual )
31 Top-level interface function, @floatInwards@. Note that we do not
32 actually float any bindings downwards from the top-level.
35 floatInwards :: [CoreBinding] -> [CoreBinding]
38 = map fi_top_bind binds
40 fi_top_bind (NonRec binder rhs)
41 = NonRec binder (fiExpr [] (freeVars rhs))
42 fi_top_bind (Rec pairs)
43 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
46 %************************************************************************
48 \subsection{Mail from Andr\'e [edited]}
50 %************************************************************************
52 {\em Will wrote: What??? I thought the idea was to float as far
53 inwards as possible, no matter what. This is dropping all bindings
54 every time it sees a lambda of any kind. Help! }
56 You are assuming we DO DO full laziness AFTER floating inwards! We
57 have to [not float inside lambdas] if we don't.
59 If we indeed do full laziness after the floating inwards (we could
60 check the compilation flags for that) then I agree we could be more
61 aggressive and do float inwards past lambdas.
63 Actually we are not doing a proper full laziness (see below), which
64 was another reason for not floating inwards past a lambda.
66 This can easily be fixed.
67 The problem is that we float lets outwards,
68 but there are a few expressions which are not
69 let bound, like case scrutinees and case alternatives.
70 After floating inwards the simplifier could decide to inline
71 the let and the laziness would be lost, e.g.
73 let a = expensive ==> \b -> case expensive of ...
74 in \ b -> case a of ...
79 to let bind the algebraic case scrutinees (done, I think) and
80 the case alternatives (except the ones with an
81 unboxed type)(not done, I think). This is best done in the
82 SetLevels.lhs module, which tags things with their level numbers.
84 do the full laziness pass (floating lets outwards).
86 simplify. The simplifier inlines the (trivial) lets that were
87 created but were not floated outwards.
90 With the fix I think Will's suggestion that we can gain even more from
91 strictness by floating inwards past lambdas makes sense.
93 We still gain even without going past lambdas, as things may be
94 strict in the (new) context of a branch (where it was floated to) or
97 let a = something case x of
98 in case x of alt1 -> case something of a -> a + a
99 alt1 -> a + a ==> alt2 -> b
102 let a = something let b = case something of a -> a + a
103 in let b = a + a ==> in (b,b)
106 Also, even if a is not found to be strict in the new context and is
107 still left as a let, if the branch is not taken (or b is not entered)
108 the closure for a is not built.
110 %************************************************************************
112 \subsection{Main floating-inwards code}
114 %************************************************************************
117 type FreeVarsSet = IdSet
119 type FloatingBinds = [(CoreBinding, FreeVarsSet)]
120 -- In dependency order (outermost first)
122 -- The FreeVarsSet is the free variables of the binding. In the case
123 -- of recursive bindings, the set doesn't include the bound
126 fiExpr :: FloatingBinds -- binds we're trying to drop
127 -- as far "inwards" as possible
128 -> CoreExprWithFVs -- input expr
129 -> CoreExpr -- result
131 fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
133 fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
135 fiExpr to_drop (_,AnnCon c atoms)
136 = mkCoLets' to_drop (Con c atoms)
138 fiExpr to_drop (_,AnnPrim c atoms)
139 = mkCoLets' to_drop (Prim c atoms)
142 Here we are not floating inside lambda (type lambdas are OK):
144 fiExpr to_drop (_,AnnLam (UsageBinder binder) body)
145 = panic "FloatIn.fiExpr:AnnLam UsageBinder"
147 fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
148 = mkCoLets' to_drop (Lam b (fiExpr [] body))
150 fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
152 -- we do not float into type lambdas if they are followed by
153 -- a whnf (actually we check for lambdas and constructors).
154 -- The reason is that a let binding will get stuck
155 -- in between the type lambda and the whnf and the simplifier
156 -- does not know how to pull it back out from a type lambda.
159 -- in let f = /\t -> \a -> ...
161 -- let f = /\t -> let v = ... in \a -> ...
162 -- which is bad as now f is an updatable closure (update PAP)
163 -- and has arity 0. This example comes from cichelli.
165 = mkCoLets' to_drop (Lam b (fiExpr [] body))
167 = Lam b (fiExpr to_drop body)
169 whnf :: CoreExprWithFVs -> Bool
171 whnf (_,AnnLit _) = True
172 whnf (_,AnnCon _ _) = True
173 whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
174 whnf (_,AnnSCC _ e) = whnf e
178 Applications: we could float inside applications, but it's probably
179 not worth it (a purely practical choice, hunch- [not experience-]
182 fiExpr to_drop (_,AnnApp fun arg)
184 = mkCoLets' to_drop (App (fiExpr [] fun) arg)
186 = App (fiExpr to_drop fun) arg
189 We don't float lets inwards past an SCC.
191 ToDo: SCC: {\em should} 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.
195 fiExpr to_drop (_, AnnSCC cc expr)
196 = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
200 fiExpr to_drop (_, AnnCoerce c ty expr)
201 = --trace "fiExpr:Coerce:wimping out" $
202 mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
205 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
206 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
207 or~(b2), in each of the RHSs of the pairs of a @Rec@.
209 Note that we do {\em weird things} with this let's binding. Consider:
218 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
219 body of the inner let, we could panic and leave \tr{w}'s binding where
220 it is. But \tr{v} is floatable into the body of the inner let, and
221 {\em then} \tr{w} will also be only in the body of that inner let.
223 So: rather than drop \tr{w}'s binding here, we add it onto the list of
224 things to drop in the outer let's body, and let nature take its
228 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body)
229 = fiExpr new_to_drop body
231 rhs_fvs = freeVarsOf rhs
232 body_fvs = freeVarsOf body
234 ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
236 new_to_drop = body_binds ++ -- the bindings used only in the body
237 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
238 shared_binds -- the bindings used both in rhs and body
240 -- Push rhs_binds into the right hand side of the binding
241 rhs' = fiExpr rhs_binds rhs
242 rhs_fvs' = rhs_fvs `unionIdSets` floatedBindsFVs rhs_binds
244 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
245 = fiExpr new_to_drop body
247 (binders, rhss) = unzip bindings
249 rhss_fvs = map freeVarsOf rhss
250 body_fvs = freeVarsOf body
252 (body_binds:rhss_binds, shared_binds)
253 = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
255 new_to_drop = -- the bindings used only in the body
257 -- the new binding itself
258 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
259 -- the bindings used both in rhs and body or in more than one rhs
262 rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs)
263 (unionManyIdSets (map floatedBindsFVs rhss_binds))
265 -- Push rhs_binds into the right hand side of the binding
266 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
267 -> [(Id, CoreExprWithFVs)]
270 fi_bind to_drops pairs
271 = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
274 For @Case@, the possible ``drop points'' for the \tr{to_drop}
275 bindings are: (a)~inside the scrutinee, (b)~inside one of the
276 alternatives/default [default FVs always {\em first}!].
279 fiExpr to_drop (_, AnnCase scrut alts)
281 fvs_scrut = freeVarsOf scrut
282 drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
284 case (sepBindsByDropPoint drop_pts_fvs to_drop)
285 of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
286 mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
287 (fi_alts deflt_drops alts_drops alts))
290 ----------------------------
291 -- pin default FVs on first!
293 get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
294 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
296 get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
297 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
299 get_deflt_fvs AnnNoDefault = emptyIdSet
300 get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
302 ----------------------------
303 fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
305 [ (con, params, fiExpr to_drop rhs)
306 | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
307 (fi_default to_drop_deflt deflt)
309 fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
311 [ (lit, fiExpr to_drop rhs)
312 | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
313 (fi_default to_drop_deflt deflt)
315 fi_default to_drop AnnNoDefault = NoDefault
316 fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
319 %************************************************************************
321 \subsection{@sepBindsByDropPoint@}
323 %************************************************************************
325 This is the crucial function. The idea is: We have a wad of bindings
326 that we'd like to distribute inside a collection of {\em drop points};
327 insides the alternatives of a \tr{case} would be one example of some
328 drop points; the RHS and body of a non-recursive \tr{let} binding
329 would be another (2-element) collection.
331 So: We're given a list of sets-of-free-variables, one per drop point,
332 and a list of floating-inwards bindings. If a binding can go into
333 only one drop point (without suddenly making something out-of-scope),
334 in it goes. If a binding is used inside {\em multiple} drop points,
335 then it has to go in a you-must-drop-it-above-all-these-drop-points
338 We have to maintain the order on these drop-point-related lists.
342 :: [FreeVarsSet] -- one set of FVs per drop point
343 -> FloatingBinds -- candidate floaters
344 -> ([FloatingBinds], -- floaters that *can* be floated into
345 -- the corresponding drop point
346 FloatingBinds) -- everything else, bindings which must
347 -- not be floated inside any drop point
349 sepBindsByDropPoint drop_pts []
350 = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
352 sepBindsByDropPoint drop_pts floaters
354 (per_drop_pt, must_stay_here, _)
355 --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
356 = split' drop_pts floaters [] empty_boxes
357 empty_boxes = nOfThem (length drop_pts) []
359 (map reverse per_drop_pt, reverse must_stay_here)
361 split' drop_pts_fvs [] mult_branch drop_boxes
362 = (drop_boxes, mult_branch, drop_pts_fvs)
364 -- only in a or unused
365 split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
366 | all (\b -> {-b `elementOfIdSet` a &&-}
367 not (b `elementOfIdSet` (unionManyIdSets as)))
368 (bindersOf (fst bind))
369 = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
371 a' = a `unionIdSets` fvsOfBind bind
374 split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
375 | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind))
376 = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
378 (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
381 split' aas@(a:as) (bind:binds) mult_branch drop_boxes
382 = split' aas' binds (bind : mult_branch) drop_boxes
384 aas' = map (unionIdSets (fvsOfBind bind)) aas
386 -------------------------
387 fvsOfBind (_,fvs) = fvs
389 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
390 floatedBindsFVs binds = unionManyIdSets (map snd binds)
392 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
393 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e