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
14 IMPORT_1_3(List(partition))
18 import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
19 import CostCentre ( dupifyCC, CostCentre )
20 import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, SYN_IE(IdEnv),
21 GenId{-instance Outputable-}, SYN_IE(Id)
23 import Outputable ( PprStyle(..), Outputable(..){-instance (,)-} )
25 import PprType ( GenTyVar )
26 import Pretty ( Doc, int, ptext, hcat, vcat )
27 import SetLevels -- all of it
28 import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
29 import Unique ( Unique{-instance Eq-} )
30 import UniqSupply ( UniqSupply )
31 import Usage ( SYN_IE(UVar) )
32 import Util ( pprTrace, panic )
38 At the moment we never float a binding out to between two adjacent
42 \x y -> let t = x+x in ...
44 \x -> let t = x+x in \y -> ...
46 Reason: this is less efficient in the case where the original lambda
47 is never partially applied.
49 But there's a case I've seen where this might not be true. Consider:
55 elem' x (y:ys) = x==y || elem' x ys
57 It turns out that this generates a subexpression of the form
59 \deq x ys -> let eq = eqFromEqDict deq in ...
61 which might usefully be separated to
63 \deq -> let eq = eqFromEqDict deq in \xy -> ...
65 Well, maybe. We don't do this at the moment.
68 type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
69 type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
70 type FloatingBind = (Level, Floater)
71 type FloatingBinds = [FloatingBind]
74 = LetFloater CoreBinding
75 | CaseFloater (CoreExpr -> CoreExpr)
76 -- A CoreExpr with a hole in it:
77 -- "Give me a right-hand side of the
78 -- (usually single) alternative, and
79 -- I'll build the case..."
82 %************************************************************************
84 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
86 %************************************************************************
89 floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
92 = case (setLevels pgm us) of { annotated_w_levels ->
94 case (unzip (map floatTopBind annotated_w_levels))
95 of { (fss, final_toplev_binds_s) ->
97 (if opt_D_verbose_core2core
98 then pprTrace "Levels added:\n"
99 (vcat (map (ppr PprDebug) annotated_w_levels))
102 ( if not (opt_D_simplifier_stats) then
106 (tlets, ntlets, lams) = get_stats (sum_stats fss)
108 pprTrace "FloatOut stats: " (hcat [
109 int tlets, ptext SLIT(" Lets floated to top level; "),
110 int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
111 int lams, ptext SLIT(" Lambda groups")])
113 concat final_toplev_binds_s
116 floatTopBind bind@(NonRec _ _)
117 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
118 (fs, floatsToBinds floats ++ [bind'])
121 floatTopBind bind@(Rec _)
122 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
123 -- Actually floats will be empty
124 --false:ASSERT(null floats)
125 (fs, [Rec (floatsToBindPairs floats ++ pairs')])
129 %************************************************************************
131 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
133 %************************************************************************
137 floatBind :: IdEnv Level
140 -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
142 floatBind env lvl (NonRec (name,level) rhs)
143 = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
145 -- A good dumping point
146 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
149 NonRec name (install heres rhs'),
150 addOneToIdEnv env name level)
153 floatBind env lvl bind@(Rec pairs)
154 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
156 if not (isTopLvl bind_level) then
158 (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
160 {- In a recursive binding, destined for the top level (only),
161 the rhs floats may contain
162 references to the bound things. For example
164 f = ...(let v = ...f... in b) ...
171 and hence we must (pessimistically) make all the floats recursive
172 with the top binding. Later dependency analysis will unravel it.
177 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
182 new_env = growIdEnvList env (map fst pairs)
184 bind_level = getBindLevel bind
186 do_pair ((name, level), rhs)
187 = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
189 -- A good dumping point
190 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
192 (fs, rhs_floats', (name, install heres rhs'))
196 %************************************************************************
198 \subsection[FloatOut-Expr]{Floating in expressions}
200 %************************************************************************
203 floatExpr :: IdEnv Level
206 -> (FloatStats, FloatingBinds, CoreExpr)
208 floatExpr env _ (Var v) = (zero_stats, [], Var v)
209 floatExpr env _ (Lit l) = (zero_stats, [], Lit l)
210 floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
211 floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
213 floatExpr env lvl (App e a)
214 = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
215 (fs, floating_defns, App e' a) }
217 floatExpr env lvl (Lam (UsageBinder _) e)
218 = panic "FloatOut.floatExpr: Lam UsageBinder"
220 floatExpr env lvl (Lam (TyBinder tv) e)
222 incd_lvl = incMinorLvl lvl
224 case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
226 -- Dump any bindings which absolutely cannot go any further
227 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
229 (fs, floats', Lam (TyBinder tv) (install heres e'))
232 floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
234 new_env = addOneToIdEnv env arg incd_lvl
236 case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
238 -- Dump any bindings which absolutely cannot go any further
239 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
241 (add_to_stats fs floats',
243 Lam (ValBinder arg) (install heres rhs'))
246 floatExpr env lvl (SCC cc expr)
247 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
249 -- annotate bindings floated outwards past an scc expression
250 -- with the cc. We mark that cc as "duplicated", though.
252 annotated_defns = annotate (dupifyCC cc) floating_defns
254 (fs, annotated_defns, SCC cc expr') }
256 annotate :: CostCentre -> FloatingBinds -> FloatingBinds
258 annotate dupd_cc defn_groups
259 = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
261 ann_bind (LetFloater (NonRec binder rhs))
262 = LetFloater (NonRec binder (ann_rhs rhs))
264 ann_bind (LetFloater (Rec pairs))
265 = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
267 ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
269 ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
270 ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
271 ann_rhs rhs = SCC dupd_cc rhs
273 -- Note: Nested SCC's are preserved for the benefit of
274 -- cost centre stack profiling (Durham)
276 floatExpr env lvl (Coerce c ty expr)
277 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
278 (fs, floating_defns, Coerce c ty expr') }
280 floatExpr env lvl (Let bind body)
281 = case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
282 case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
284 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
288 bind_lvl = getBindLevel bind
290 floatExpr env lvl (Case scrut alts)
291 = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
293 case (scrut', float_alts alts) of
294 (_, (fsa, fda, alts')) ->
295 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
297 {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
299 (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
300 | scrut_var_lvl `ltMajLvl` lvl ->
302 -- Candidate for case floater; scrutinising a variable; it can
303 -- escape outside a lambda; there's only one alternative.
304 (fda ++ fde ++ [case_floater], rhs')
307 case_floater = (scrut_var_lvl, CaseFloater fn)
308 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
309 scrut_var_lvl = case lookupIdEnv env scrut_var of
311 Just lvl -> unTopify lvl
313 END OF CASE FLOATING DROPPED -}
315 incd_lvl = incMinorLvl lvl
317 partition_fn = partitionByMajorLevel
320 We don't want to be too keen about floating lets out of case alternatives
321 because they may benefit from seeing the evaluation done by the case.
323 The main reason for doing this is to allocate in fewer larger blocks
324 but that's really an STG-level issue.
327 -- Just one alternative, then dump only
328 -- what *has* to be dumped
329 AlgAlts [_] NoDefault -> partitionByLevel
330 AlgAlts [] (BindDefault _ _) -> partitionByLevel
331 PrimAlts [_] NoDefault -> partitionByLevel
332 PrimAlts [] (BindDefault _ _) -> partitionByLevel
334 -- If there's more than one alternative, then
335 -- this is a dumping point
336 other -> partitionByMajorLevel
339 float_alts (AlgAlts alts deflt)
340 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
341 case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
342 (foldr add_stats fsd fsas,
344 AlgAlts alts' deflt') }}
346 float_alts (PrimAlts alts deflt)
347 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
348 case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
349 (foldr add_stats fsd fsas,
351 PrimAlts alts' deflt') }}
354 float_alg_alt (con, bs, rhs)
357 new_env = growIdEnvList env bs
359 case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
360 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
361 (fs, rhs_floats', (con, bs', install heres rhs')) }}
364 float_prim_alt (lit, rhs)
365 = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
366 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
367 (fs, rhs_floats', (lit, install heres rhs')) }}
370 float_deflt NoDefault = (zero_stats, [], NoDefault)
372 float_deflt (BindDefault (b,lvl) rhs)
373 = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
374 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
375 (fs, rhs_floats', BindDefault b (install heres rhs')) }}
377 new_env = addOneToIdEnv env b lvl
380 %************************************************************************
382 \subsection{Utility bits for floating stats}
384 %************************************************************************
386 I didn't implement this with unboxed numbers. I don't want to be too
387 strict in this stuff, as it is rarely turned on. (WDP 95/09)
391 = FlS Int -- Number of top-floats * lambda groups they've been past
392 Int -- Number of non-top-floats * lambda groups they've been past
393 Int -- Number of lambda (groups) seen
395 get_stats (FlS a b c) = (a, b, c)
397 zero_stats = FlS 0 0 0
399 sum_stats xs = foldr add_stats zero_stats xs
401 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
402 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
404 add_to_stats (FlS a b c) floats
405 = FlS (a + length top_floats) (b + length other_floats) (c + 1)
407 (top_floats, other_floats) = partition to_very_top floats
409 to_very_top (my_lvl, _) = isTopLvl my_lvl
412 %************************************************************************
414 \subsection{Utility bits for floating}
416 %************************************************************************
419 getBindLevel (NonRec (_, lvl) _) = lvl
420 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
424 partitionByMajorLevel, partitionByLevel
425 :: Level -- Partitioning level
427 -> FloatingBinds -- Defns to be divided into 2 piles...
429 -> (FloatingBinds, -- Defns with level strictly < partition level,
430 FloatingBinds) -- The rest
433 partitionByMajorLevel ctxt_lvl defns
434 = partition float_further defns
436 float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
439 partitionByLevel ctxt_lvl defns
440 = partition float_further defns
442 float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
446 floatsToBinds :: FloatingBinds -> [CoreBinding]
447 floatsToBinds floats = map get_bind floats
449 get_bind (_, LetFloater bind) = bind
450 get_bind (_, CaseFloater _) = panic "floatsToBinds"
452 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
454 floatsToBindPairs floats = concat (map mk_pairs floats)
456 mk_pairs (_, LetFloater (Rec pairs)) = pairs
457 mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
458 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
460 install :: FloatingBinds -> CoreExpr -> CoreExpr
462 install defn_groups expr
463 = foldr install_group expr defn_groups
465 install_group (_, LetFloater defns) body = Let defns body
466 install_group (_, CaseFloater fn) body = fn body