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"
20 -- and to make the interface self-sufficient...
30 Top-level interface function, @floatInwards@. Note that we do not
31 actually float any bindings downwards from the top-level.
34 floatInwards :: [CoreBinding] -> [CoreBinding]
37 = map fi_top_bind binds
39 fi_top_bind (NonRec binder rhs)
40 = NonRec binder (fiExpr [] (freeVars rhs))
41 fi_top_bind (Rec pairs)
42 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
45 %************************************************************************
47 \subsection{Mail from Andr\'e [edited]}
49 %************************************************************************
51 {\em Will wrote: What??? I thought the idea was to float as far
52 inwards as possible, no matter what. This is dropping all bindings
53 every time it sees a lambda of any kind. Help! }
55 You are assuming we DO DO full laziness AFTER floating inwards! We
56 have to [not float inside lambdas] if we don't.
58 If we indeed do full laziness after the floating inwards (we could
59 check the compilation flags for that) then I agree we could be more
60 aggressive and do float inwards past lambdas.
62 Actually we are not doing a proper full laziness (see below), which
63 was another reason for not floating inwards past a lambda.
65 This can easily be fixed.
66 The problem is that we float lets outwards,
67 but there are a few expressions which are not
68 let bound, like case scrutinees and case alternatives.
69 After floating inwards the simplifier could decide to inline
70 the let and the laziness would be lost, e.g.
72 let a = expensive ==> \b -> case expensive of ...
73 in \ b -> case a of ...
78 to let bind the algebraic case scrutinees (done, I think) and
79 the case alternatives (except the ones with an
80 unboxed type)(not done, I think). This is best done in the
81 SetLevels.lhs module, which tags things with their level numbers.
83 do the full laziness pass (floating lets outwards).
85 simplify. The simplifier inlines the (trivial) lets that were
86 created but were not floated outwards.
89 With the fix I think Will's suggestion that we can gain even more from
90 strictness by floating inwards past lambdas makes sense.
92 We still gain even without going past lambdas, as things may be
93 strict in the (new) context of a branch (where it was floated to) or
96 let a = something case x of
97 in case x of alt1 -> case something of a -> a + a
98 alt1 -> a + a ==> alt2 -> b
101 let a = something let b = case something of a -> a + a
102 in let b = a + a ==> in (b,b)
105 Also, even if a is not found to be strict in the new context and is
106 still left as a let, if the branch is not taken (or b is not entered)
107 the closure for a is not built.
109 %************************************************************************
111 \subsection{Main floating-inwards code}
113 %************************************************************************
116 type FreeVarsSet = UniqSet Id
118 type FloatingBinds = [(CoreBinding, FreeVarsSet)]
119 -- In dependency order (outermost first)
121 -- The FreeVarsSet is the free variables of the binding. In the case
122 -- of recursive bindings, the set doesn't include the bound
125 fiExpr :: FloatingBinds -- binds we're trying to drop
126 -- as far "inwards" as possible
127 -> CoreExprWithFVs -- input expr
128 -> CoreExpr -- result
130 fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (Var v)
132 fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (Lit k)
134 fiExpr to_drop (_,AnnCoCon c tys atoms)
135 = mkCoLets' to_drop (Con c tys atoms)
137 fiExpr to_drop (_,AnnCoPrim c tys atoms)
138 = mkCoLets' to_drop (Prim c tys atoms)
141 Here we are not floating inside lambda (type lambdas are OK):
143 fiExpr to_drop (_,AnnCoLam binder body)
144 = mkCoLets' to_drop (Lam binder (fiExpr [] body))
146 fiExpr to_drop (_,AnnCoTyLam tyvar body)
148 -- we do not float into type lambdas if they are followed by
149 -- a whnf (actually we check for lambdas and constructors).
150 -- The reason is that a let binding will get stuck
151 -- in between the type lambda and the whnf and the simplifier
152 -- does not know how to pull it back out from a type lambda.
155 -- in let f = /\t -> \a -> ...
157 -- let f = /\t -> let v = ... in \a -> ...
158 -- which is bad as now f is an updatable closure (update PAP)
159 -- and has arity 0. This example comes from cichelli.
160 = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body))
162 = CoTyLam tyvar (fiExpr to_drop body)
164 whnf :: CoreExprWithFVs -> Bool
165 whnf (_,AnnCoLit _) = True
166 whnf (_,AnnCoCon _ _ _) = True
167 whnf (_,AnnCoLam _ _) = True
168 whnf (_,AnnCoTyLam _ e) = whnf e
169 whnf (_,AnnCoSCC _ 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 (_,AnnCoApp fun atom)
178 = mkCoLets' to_drop (App (fiExpr [] fun) atom)
180 fiExpr to_drop (_,AnnCoTyApp expr ty)
181 = CoTyApp (fiExpr to_drop expr) ty
184 We don't float lets inwards past an SCC.
186 ToDo: SCC: {\em should} keep info on current cc, and when passing
187 one, if it is not the same, annotate all lets in binds with current
188 cc, change current cc to the new one and float binds into expr.
190 fiExpr to_drop (_, AnnCoSCC cc expr)
191 = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
194 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
195 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
196 or~(b2), in each of the RHSs of the pairs of a @Rec@.
198 Note that we do {\em weird things} with this let's binding. Consider:
207 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
208 body of the inner let, we could panic and leave \tr{w}'s binding where
209 it is. But \tr{v} is floatable into the body of the inner let, and
210 {\em then} \tr{w} will also be only in the body of that inner let.
212 So: rather than drop \tr{w}'s binding here, we add it onto the list of
213 things to drop in the outer let's body, and let nature take its
217 fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body)
218 = fiExpr new_to_drop body
220 rhs_fvs = freeVarsOf rhs
221 body_fvs = freeVarsOf body
223 ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
225 new_to_drop = body_binds ++ -- the bindings used only in the body
226 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
227 shared_binds -- the bindings used both in rhs and body
229 -- Push rhs_binds into the right hand side of the binding
230 rhs' = fiExpr rhs_binds rhs
231 rhs_fvs' = rhs_fvs `unionUniqSets` (floatedBindsFVs rhs_binds)
233 fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body)
234 = fiExpr new_to_drop body
236 (binders, rhss) = unzip bindings
238 rhss_fvs = map freeVarsOf rhss
239 body_fvs = freeVarsOf body
241 (body_binds:rhss_binds, shared_binds)
242 = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
244 new_to_drop = -- the bindings used only in the body
246 -- the new binding itself
247 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
248 -- the bindings used both in rhs and body or in more than one rhs
251 rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
252 (unionManyUniqSets (map floatedBindsFVs rhss_binds))
254 -- Push rhs_binds into the right hand side of the binding
255 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
256 -> [(Id, CoreExprWithFVs)]
259 fi_bind to_drops pairs
260 = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
263 For @Case@, the possible ``drop points'' for the \tr{to_drop}
264 bindings are: (a)~inside the scrutinee, (b)~inside one of the
265 alternatives/default [default FVs always {\em first}!].
268 fiExpr to_drop (_, AnnCoCase scrut alts)
270 fvs_scrut = freeVarsOf scrut
271 drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
273 case (sepBindsByDropPoint drop_pts_fvs to_drop)
274 of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
275 mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
276 (fi_alts deflt_drops alts_drops alts))
279 ----------------------------
280 -- pin default FVs on first!
282 get_fvs_from_deflt_and_alts (AnnCoAlgAlts alts deflt)
283 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
285 get_fvs_from_deflt_and_alts (AnnCoPrimAlts alts deflt)
286 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
288 get_deflt_fvs AnnCoNoDefault = emptyUniqSet
289 get_deflt_fvs (AnnCoBindDefault b rhs) = freeVarsOf rhs
291 ----------------------------
292 fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt)
294 [ (con, params, fiExpr to_drop rhs)
295 | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
296 (fi_default to_drop_deflt deflt)
298 fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt)
300 [ (lit, fiExpr to_drop rhs)
301 | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
302 (fi_default to_drop_deflt deflt)
304 fi_default to_drop AnnCoNoDefault = NoDefault
305 fi_default to_drop (AnnCoBindDefault b e) = BindDefault b (fiExpr to_drop e)
308 %************************************************************************
310 \subsection{@sepBindsByDropPoint@}
312 %************************************************************************
314 This is the crucial function. The idea is: We have a wad of bindings
315 that we'd like to distribute inside a collection of {\em drop points};
316 insides the alternatives of a \tr{case} would be one example of some
317 drop points; the RHS and body of a non-recursive \tr{let} binding
318 would be another (2-element) collection.
320 So: We're given a list of sets-of-free-variables, one per drop point,
321 and a list of floating-inwards bindings. If a binding can go into
322 only one drop point (without suddenly making something out-of-scope),
323 in it goes. If a binding is used inside {\em multiple} drop points,
324 then it has to go in a you-must-drop-it-above-all-these-drop-points
327 We have to maintain the order on these drop-point-related lists.
331 :: [FreeVarsSet] -- one set of FVs per drop point
332 -> FloatingBinds -- candidate floaters
333 -> ([FloatingBinds], -- floaters that *can* be floated into
334 -- the corresponding drop point
335 FloatingBinds) -- everything else, bindings which must
336 -- not be floated inside any drop point
338 sepBindsByDropPoint drop_pts []
339 = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
341 sepBindsByDropPoint drop_pts floaters
343 (per_drop_pt, must_stay_here, _)
344 --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters
345 = split' drop_pts floaters [] empty_boxes
346 empty_boxes = take (length drop_pts) (repeat [])
349 (map reverse per_drop_pt, reverse must_stay_here)
351 split' drop_pts_fvs [] mult_branch drop_boxes
352 = (drop_boxes, mult_branch, drop_pts_fvs)
354 -- only in a or unused
355 split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
356 | all (\b -> {-b `elementOfUniqSet` a &&-}
357 not (b `elementOfUniqSet` (unionManyUniqSets as)))
358 (bindersOf (fst bind))
359 = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
361 a' = a `unionUniqSets` fvsOfBind bind
364 split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
365 | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind))
366 = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
368 (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
371 split' aas@(a:as) (bind:binds) mult_branch drop_boxes
372 = split' aas' binds (bind : mult_branch) drop_boxes
374 aas' = map (unionUniqSets (fvsOfBind bind)) aas
376 -------------------------
377 fvsOfBind (_,fvs) = fvs
380 floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds)
382 --mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
383 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e