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 module FloatOut ( floatOutwards ) where
11 #include "HsVersions.h"
15 import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
16 import CostCentre ( dupifyCC, CostCentre )
17 import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv,
21 import SetLevels -- all of it
22 import BasicTypes ( Unused )
23 import TyVar ( TyVar )
24 import UniqSupply ( UniqSupply )
25 import List ( partition )
32 At the moment we never float a binding out to between two adjacent
36 \x y -> let t = x+x in ...
38 \x -> let t = x+x in \y -> ...
40 Reason: this is less efficient in the case where the original lambda
41 is never partially applied.
43 But there's a case I've seen where this might not be true. Consider:
49 elem' x (y:ys) = x==y || elem' x ys
51 It turns out that this generates a subexpression of the form
53 \deq x ys -> let eq = eqFromEqDict deq in ...
55 which might usefully be separated to
57 \deq -> let eq = eqFromEqDict deq in \xy -> ...
59 Well, maybe. We don't do this at the moment.
62 type LevelledExpr = GenCoreExpr (Id, Level) Id Unused
63 type LevelledBind = GenCoreBinding (Id, Level) Id Unused
64 type FloatingBind = (Level, Floater)
65 type FloatingBinds = [FloatingBind]
68 = LetFloater CoreBinding
69 | CaseFloater (CoreExpr -> CoreExpr)
70 -- A CoreExpr with a hole in it:
71 -- "Give me a right-hand side of the
72 -- (usually single) alternative, and
73 -- I'll build the case..."
76 %************************************************************************
78 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
80 %************************************************************************
83 floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
86 = case (setLevels pgm us) of { annotated_w_levels ->
88 case (unzip (map floatTopBind annotated_w_levels))
89 of { (fss, final_toplev_binds_s) ->
91 (if opt_D_verbose_core2core
92 then pprTrace "Levels added:\n"
93 (vcat (map (ppr) annotated_w_levels))
96 ( if not (opt_D_simplifier_stats) then
100 (tlets, ntlets, lams) = get_stats (sum_stats fss)
102 pprTrace "FloatOut stats: " (hcat [
103 int tlets, ptext SLIT(" Lets floated to top level; "),
104 int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
105 int lams, ptext SLIT(" Lambda groups")])
107 concat final_toplev_binds_s
110 floatTopBind bind@(NonRec _ _)
111 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
112 (fs, floatsToBinds floats ++ [bind'])
115 floatTopBind bind@(Rec _)
116 = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
117 -- Actually floats will be empty
118 --false:ASSERT(null floats)
119 (fs, [Rec (floatsToBindPairs floats ++ pairs')])
123 %************************************************************************
125 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
127 %************************************************************************
131 floatBind :: IdEnv Level
134 -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
136 floatBind env lvl (NonRec (name,level) rhs)
137 = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
139 -- A good dumping point
140 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
143 NonRec name (install heres rhs'),
144 addOneToIdEnv env name level)
147 floatBind env lvl bind@(Rec pairs)
148 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
150 if not (isTopLvl bind_level) then
152 (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
154 {- In a recursive binding, destined for the top level (only),
155 the rhs floats may contain
156 references to the bound things. For example
158 f = ...(let v = ...f... in b) ...
165 and hence we must (pessimistically) make all the floats recursive
166 with the top binding. Later dependency analysis will unravel it.
171 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
176 new_env = growIdEnvList env (map fst pairs)
178 bind_level = getBindLevel bind
180 do_pair ((name, level), rhs)
181 = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
183 -- A good dumping point
184 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
186 (fs, rhs_floats', (name, install heres rhs'))
190 %************************************************************************
192 \subsection[FloatOut-Expr]{Floating in expressions}
194 %************************************************************************
197 floatExpr :: IdEnv Level
200 -> (FloatStats, FloatingBinds, CoreExpr)
202 floatExpr env _ (Var v) = (zero_stats, [], Var v)
203 floatExpr env _ (Lit l) = (zero_stats, [], Lit l)
204 floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
205 floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
207 floatExpr env lvl (App e a)
208 = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
209 (fs, floating_defns, App e' a) }
211 floatExpr env lvl (Lam (TyBinder tv) e)
213 incd_lvl = incMinorLvl lvl
215 case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
217 -- Dump any bindings which absolutely cannot go any further
218 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
220 (fs, floats', Lam (TyBinder tv) (install heres e'))
223 floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
225 new_env = addOneToIdEnv env arg incd_lvl
227 case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
229 -- Dump any bindings which absolutely cannot go any further
230 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
232 (add_to_stats fs floats',
234 Lam (ValBinder arg) (install heres rhs'))
237 floatExpr env lvl (Note note@(SCC cc) expr)
238 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
240 -- annotate bindings floated outwards past an scc expression
241 -- with the cc. We mark that cc as "duplicated", though.
243 annotated_defns = annotate (dupifyCC cc) floating_defns
245 (fs, annotated_defns, Note note expr') }
247 annotate :: CostCentre -> FloatingBinds -> FloatingBinds
249 annotate dupd_cc defn_groups
250 = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
252 ann_bind (LetFloater (NonRec binder rhs))
253 = LetFloater (NonRec binder (ann_rhs rhs))
255 ann_bind (LetFloater (Rec pairs))
256 = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
258 ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> Note (SCC dupd_cc) (fn rhs) )
260 ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
261 ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
262 ann_rhs rhs = Note (SCC dupd_cc) rhs
264 -- Note: Nested SCC's are preserved for the benefit of
265 -- cost centre stack profiling (Durham)
267 floatExpr env lvl (Note note expr) -- Other than SCCs
268 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
269 (fs, floating_defns, Note note expr') }
271 floatExpr env lvl (Let bind body)
272 = case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
273 case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
275 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
279 bind_lvl = getBindLevel bind
281 floatExpr env lvl (Case scrut alts)
282 = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
284 case (scrut', float_alts alts) of
285 (_, (fsa, fda, alts')) ->
286 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
288 {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
290 (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
291 | scrut_var_lvl `ltMajLvl` lvl ->
293 -- Candidate for case floater; scrutinising a variable; it can
294 -- escape outside a lambda; there's only one alternative.
295 (fda ++ fde ++ [case_floater], rhs')
298 case_floater = (scrut_var_lvl, CaseFloater fn)
299 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
300 scrut_var_lvl = case lookupIdEnv env scrut_var of
302 Just lvl -> unTopify lvl
304 END OF CASE FLOATING DROPPED -}
306 incd_lvl = incMinorLvl lvl
308 partition_fn = partitionByMajorLevel
311 We don't want to be too keen about floating lets out of case alternatives
312 because they may benefit from seeing the evaluation done by the case.
314 The main reason for doing this is to allocate in fewer larger blocks
315 but that's really an STG-level issue.
318 -- Just one alternative, then dump only
319 -- what *has* to be dumped
320 AlgAlts [_] NoDefault -> partitionByLevel
321 AlgAlts [] (BindDefault _ _) -> partitionByLevel
322 PrimAlts [_] NoDefault -> partitionByLevel
323 PrimAlts [] (BindDefault _ _) -> partitionByLevel
325 -- If there's more than one alternative, then
326 -- this is a dumping point
327 other -> partitionByMajorLevel
330 float_alts (AlgAlts alts deflt)
331 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
332 case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
333 (foldr add_stats fsd fsas,
335 AlgAlts alts' deflt') }}
337 float_alts (PrimAlts alts deflt)
338 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
339 case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
340 (foldr add_stats fsd fsas,
342 PrimAlts alts' deflt') }}
345 float_alg_alt (con, bs, rhs)
348 new_env = growIdEnvList env bs
350 case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
351 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
352 (fs, rhs_floats', (con, bs', install heres rhs')) }}
355 float_prim_alt (lit, rhs)
356 = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
357 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
358 (fs, rhs_floats', (lit, install heres rhs')) }}
361 float_deflt NoDefault = (zero_stats, [], NoDefault)
363 float_deflt (BindDefault (b,lvl) rhs)
364 = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
365 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
366 (fs, rhs_floats', BindDefault b (install heres rhs')) }}
368 new_env = addOneToIdEnv env b lvl
371 %************************************************************************
373 \subsection{Utility bits for floating stats}
375 %************************************************************************
377 I didn't implement this with unboxed numbers. I don't want to be too
378 strict in this stuff, as it is rarely turned on. (WDP 95/09)
382 = FlS Int -- Number of top-floats * lambda groups they've been past
383 Int -- Number of non-top-floats * lambda groups they've been past
384 Int -- Number of lambda (groups) seen
386 get_stats (FlS a b c) = (a, b, c)
388 zero_stats = FlS 0 0 0
390 sum_stats xs = foldr add_stats zero_stats xs
392 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
393 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
395 add_to_stats (FlS a b c) floats
396 = FlS (a + length top_floats) (b + length other_floats) (c + 1)
398 (top_floats, other_floats) = partition to_very_top floats
400 to_very_top (my_lvl, _) = isTopLvl my_lvl
403 %************************************************************************
405 \subsection{Utility bits for floating}
407 %************************************************************************
410 getBindLevel (NonRec (_, lvl) _) = lvl
411 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
415 partitionByMajorLevel, partitionByLevel
416 :: Level -- Partitioning level
418 -> FloatingBinds -- Defns to be divided into 2 piles...
420 -> (FloatingBinds, -- Defns with level strictly < partition level,
421 FloatingBinds) -- The rest
424 partitionByMajorLevel ctxt_lvl defns
425 = partition float_further defns
427 float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
430 partitionByLevel ctxt_lvl defns
431 = partition float_further defns
433 float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
437 floatsToBinds :: FloatingBinds -> [CoreBinding]
438 floatsToBinds floats = map get_bind floats
440 get_bind (_, LetFloater bind) = bind
441 get_bind (_, CaseFloater _) = panic "floatsToBinds"
443 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
445 floatsToBindPairs floats = concat (map mk_pairs floats)
447 mk_pairs (_, LetFloater (Rec pairs)) = pairs
448 mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
449 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
451 install :: FloatingBinds -> CoreExpr -> CoreExpr
453 install defn_groups expr
454 = foldr install_group expr defn_groups
456 install_group (_, LetFloater defns) body = Let defns body
457 install_group (_, CaseFloater fn) body = fn body