2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[FloatOut]{Float bindings outwards (towards the top level)}
6 ``Long-distance'' floating of bindings towards the top level.
9 #include "HsVersions.h"
11 module FloatOut ( floatOutwards ) where
17 import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
18 import CostCentre ( dupifyCC )
19 import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv(..),
20 GenId{-instance Outputable-}
22 import Outputable ( Outputable(..){-instance (,)-} )
23 import PprCore ( GenCoreBinding{-instance-} )
24 import PprStyle ( PprStyle(..) )
25 import PprType -- too lazy to type in all the instances
26 import Pretty ( ppInt, ppStr, ppBesides, ppAboves )
27 import SetLevels -- all of it
28 import TyVar ( GenTyVar{-instance Eq-} )
29 import Unique ( Unique{-instance Eq-} )
30 import Usage ( UVar(..) )
31 import Util ( pprTrace, panic )
37 At the moment we never float a binding out to between two adjacent
41 \x y -> let t = x+x in ...
43 \x -> let t = x+x in \y -> ...
45 Reason: this is less efficient in the case where the original lambda
46 is never partially applied.
48 But there's a case I've seen where this might not be true. Consider:
54 elem' x (y:ys) = x==y || elem' x ys
56 It turns out that this generates a subexpression of the form
58 \deq x ys -> let eq = eqFromEqDict deq in ...
60 which might usefully be separated to
62 \deq -> let eq = eqFromEqDict deq in \xy -> ...
64 Well, maybe. We don't do this at the moment.
67 type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
68 type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
69 type FloatingBind = (Level, Floater)
70 type FloatingBinds = [FloatingBind]
73 = LetFloater CoreBinding
74 | CaseFloater (CoreExpr -> CoreExpr)
75 -- A CoreExpr with a hole in it:
76 -- "Give me a right-hand side of the
77 -- (usually single) alternative, and
78 -- I'll build the case..."
81 %************************************************************************
83 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
85 %************************************************************************
88 floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
91 = case (setLevels pgm us) of { annotated_w_levels ->
93 case (unzip (map floatTopBind annotated_w_levels))
94 of { (fss, final_toplev_binds_s) ->
96 (if opt_D_verbose_core2core
97 then pprTrace "Levels added:\n"
98 (ppAboves (map (ppr PprDebug) annotated_w_levels))
101 ( if not (opt_D_simplifier_stats) then
105 (tlets, ntlets, lams) = get_stats (sum_stats fss)
107 pprTrace "FloatOut stats: " (ppBesides [
108 ppInt tlets, ppStr " Lets floated to top level; ",
109 ppInt ntlets, ppStr " Lets floated elsewhere; from ",
110 ppInt lams, ppStr " Lambda groups"])
112 concat final_toplev_binds_s
115 floatTopBind bind@(NonRec _ _)
116 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
117 (fs, floatsToBinds floats ++ [bind'])
120 floatTopBind bind@(Rec _)
121 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
122 -- Actually floats will be empty
123 --false:ASSERT(null floats)
124 (fs, [Rec (floatsToBindPairs floats ++ pairs')])
128 %************************************************************************
130 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
132 %************************************************************************
136 floatBind :: IdEnv Level
139 -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
141 floatBind env lvl (NonRec (name,level) rhs)
142 = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
144 -- A good dumping point
145 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
148 NonRec name (install heres rhs'),
149 addOneToIdEnv env name level)
152 floatBind env lvl bind@(Rec pairs)
153 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
155 if not (isTopLvl bind_level) then
157 (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
159 {- In a recursive binding, destined for the top level (only),
160 the rhs floats may contain
161 references to the bound things. For example
163 f = ...(let v = ...f... in b) ...
170 and hence we must (pessimistically) make all the floats recursive
171 with the top binding. Later dependency analysis will unravel it.
176 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
181 new_env = growIdEnvList env (map fst pairs)
183 bind_level = getBindLevel bind
185 do_pair ((name, level), rhs)
186 = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
188 -- A good dumping point
189 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
191 (fs, rhs_floats', (name, install heres rhs'))
195 %************************************************************************
197 \subsection[FloatOut-Expr]{Floating in expressions}
199 %************************************************************************
202 floatExpr :: IdEnv Level
205 -> (FloatStats, FloatingBinds, CoreExpr)
207 floatExpr env _ (Var v) = (zero_stats, [], Var v)
208 floatExpr env _ (Lit l) = (zero_stats, [], Lit l)
209 floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
210 floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
212 floatExpr env lvl (App e a)
213 = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
214 (fs, floating_defns, App e' a) }
216 floatExpr env lvl (Lam (UsageBinder _) e)
217 = panic "FloatOut.floatExpr: Lam UsageBinder"
219 floatExpr env lvl (Lam (TyBinder tv) e)
221 incd_lvl = incMinorLvl lvl
223 case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
225 -- Dump any bindings which absolutely cannot go any further
226 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
228 (fs, floats', Lam (TyBinder tv) (install heres e'))
231 floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
233 new_env = addOneToIdEnv env arg incd_lvl
235 case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
237 -- Dump any bindings which absolutely cannot go any further
238 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
240 (add_to_stats fs floats',
242 Lam (ValBinder arg) (install heres rhs'))
245 floatExpr env lvl (SCC cc expr)
246 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
248 -- annotate bindings floated outwards past an scc expression
249 -- with the cc. We mark that cc as "duplicated", though.
251 annotated_defns = annotate (dupifyCC cc) floating_defns
253 (fs, annotated_defns, SCC cc expr') }
255 annotate :: CostCentre -> FloatingBinds -> FloatingBinds
257 annotate dupd_cc defn_groups
258 = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
260 ann_bind (LetFloater (NonRec binder rhs))
261 = LetFloater (NonRec binder (ann_rhs rhs))
263 ann_bind (LetFloater (Rec pairs))
264 = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
266 ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
268 ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
269 ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
270 ann_rhs rhs = SCC dupd_cc rhs
272 -- Note: Nested SCC's are preserved for the benefit of
273 -- cost centre stack profiling (Durham)
275 floatExpr env lvl (Let bind body)
276 = case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
277 case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
279 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
283 bind_lvl = getBindLevel bind
285 floatExpr env lvl (Case scrut alts)
286 = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
288 case (scrut', float_alts alts) of
289 (_, (fsa, fda, alts')) ->
290 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
292 {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
294 (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
295 | scrut_var_lvl `ltMajLvl` lvl ->
297 -- Candidate for case floater; scrutinising a variable; it can
298 -- escape outside a lambda; there's only one alternative.
299 (fda ++ fde ++ [case_floater], rhs')
302 case_floater = (scrut_var_lvl, CaseFloater fn)
303 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
304 scrut_var_lvl = case lookupIdEnv env scrut_var of
306 Just lvl -> unTopify lvl
308 END OF CASE FLOATING DROPPED -}
310 incd_lvl = incMinorLvl lvl
312 partition_fn = partitionByMajorLevel
315 We don't want to be too keen about floating lets out of case alternatives
316 because they may benefit from seeing the evaluation done by the case.
318 The main reason for doing this is to allocate in fewer larger blocks
319 but that's really an STG-level issue.
322 -- Just one alternative, then dump only
323 -- what *has* to be dumped
324 AlgAlts [_] NoDefault -> partitionByLevel
325 AlgAlts [] (BindDefault _ _) -> partitionByLevel
326 PrimAlts [_] NoDefault -> partitionByLevel
327 PrimAlts [] (BindDefault _ _) -> partitionByLevel
329 -- If there's more than one alternative, then
330 -- this is a dumping point
331 other -> partitionByMajorLevel
334 float_alts (AlgAlts alts deflt)
335 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
336 case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
337 (foldr add_stats fsd fsas,
339 AlgAlts alts' deflt') }}
341 float_alts (PrimAlts alts deflt)
342 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
343 case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
344 (foldr add_stats fsd fsas,
346 PrimAlts alts' deflt') }}
349 float_alg_alt (con, bs, rhs)
352 new_env = growIdEnvList env bs
354 case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
355 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
356 (fs, rhs_floats', (con, bs', install heres rhs')) }}
359 float_prim_alt (lit, rhs)
360 = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
361 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
362 (fs, rhs_floats', (lit, install heres rhs')) }}
365 float_deflt NoDefault = (zero_stats, [], NoDefault)
367 float_deflt (BindDefault (b,lvl) rhs)
368 = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
369 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
370 (fs, rhs_floats', BindDefault b (install heres rhs')) }}
372 new_env = addOneToIdEnv env b lvl
375 %************************************************************************
377 \subsection{Utility bits for floating stats}
379 %************************************************************************
381 I didn't implement this with unboxed numbers. I don't want to be too
382 strict in this stuff, as it is rarely turned on. (WDP 95/09)
386 = FlS Int -- Number of top-floats * lambda groups they've been past
387 Int -- Number of non-top-floats * lambda groups they've been past
388 Int -- Number of lambda (groups) seen
390 get_stats (FlS a b c) = (a, b, c)
392 zero_stats = FlS 0 0 0
394 sum_stats xs = foldr add_stats zero_stats xs
396 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
397 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
399 add_to_stats (FlS a b c) floats
400 = FlS (a + length top_floats) (b + length other_floats) (c + 1)
402 (top_floats, other_floats) = partition to_very_top floats
404 to_very_top (my_lvl, _) = isTopLvl my_lvl
407 %************************************************************************
409 \subsection{Utility bits for floating}
411 %************************************************************************
414 getBindLevel (NonRec (_, lvl) _) = lvl
415 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
419 partitionByMajorLevel, partitionByLevel
420 :: Level -- Partitioning level
422 -> FloatingBinds -- Defns to be divided into 2 piles...
424 -> (FloatingBinds, -- Defns with level strictly < partition level,
425 FloatingBinds) -- The rest
428 partitionByMajorLevel ctxt_lvl defns
429 = partition float_further defns
431 float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
434 partitionByLevel ctxt_lvl defns
435 = partition float_further defns
437 float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
441 floatsToBinds :: FloatingBinds -> [CoreBinding]
442 floatsToBinds floats = map get_bind floats
444 get_bind (_, LetFloater bind) = bind
445 get_bind (_, CaseFloater _) = panic "floatsToBinds"
447 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
449 floatsToBindPairs floats = concat (map mk_pairs floats)
451 mk_pairs (_, LetFloater (Rec pairs)) = pairs
452 mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
453 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
455 install :: FloatingBinds -> CoreExpr -> CoreExpr
457 install defn_groups expr
458 = foldr install_group expr defn_groups
460 install_group (_, LetFloater defns) body = Let defns body
461 install_group (_, CaseFloater fn) body = fn body