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 ( GenTyVar )
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 (Coerce c ty expr)
276 = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
277 (fs, floating_defns, Coerce c ty expr') }
279 floatExpr env lvl (Let bind body)
280 = case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
281 case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
283 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
287 bind_lvl = getBindLevel bind
289 floatExpr env lvl (Case scrut alts)
290 = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
292 case (scrut', float_alts alts) of
293 (_, (fsa, fda, alts')) ->
294 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
296 {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
298 (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
299 | scrut_var_lvl `ltMajLvl` lvl ->
301 -- Candidate for case floater; scrutinising a variable; it can
302 -- escape outside a lambda; there's only one alternative.
303 (fda ++ fde ++ [case_floater], rhs')
306 case_floater = (scrut_var_lvl, CaseFloater fn)
307 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
308 scrut_var_lvl = case lookupIdEnv env scrut_var of
310 Just lvl -> unTopify lvl
312 END OF CASE FLOATING DROPPED -}
314 incd_lvl = incMinorLvl lvl
316 partition_fn = partitionByMajorLevel
319 We don't want to be too keen about floating lets out of case alternatives
320 because they may benefit from seeing the evaluation done by the case.
322 The main reason for doing this is to allocate in fewer larger blocks
323 but that's really an STG-level issue.
326 -- Just one alternative, then dump only
327 -- what *has* to be dumped
328 AlgAlts [_] NoDefault -> partitionByLevel
329 AlgAlts [] (BindDefault _ _) -> partitionByLevel
330 PrimAlts [_] NoDefault -> partitionByLevel
331 PrimAlts [] (BindDefault _ _) -> partitionByLevel
333 -- If there's more than one alternative, then
334 -- this is a dumping point
335 other -> partitionByMajorLevel
338 float_alts (AlgAlts alts deflt)
339 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
340 case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
341 (foldr add_stats fsd fsas,
343 AlgAlts alts' deflt') }}
345 float_alts (PrimAlts alts deflt)
346 = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
347 case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
348 (foldr add_stats fsd fsas,
350 PrimAlts alts' deflt') }}
353 float_alg_alt (con, bs, rhs)
356 new_env = growIdEnvList env bs
358 case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
359 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
360 (fs, rhs_floats', (con, bs', install heres rhs')) }}
363 float_prim_alt (lit, rhs)
364 = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
365 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
366 (fs, rhs_floats', (lit, install heres rhs')) }}
369 float_deflt NoDefault = (zero_stats, [], NoDefault)
371 float_deflt (BindDefault (b,lvl) rhs)
372 = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
373 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
374 (fs, rhs_floats', BindDefault b (install heres rhs')) }}
376 new_env = addOneToIdEnv env b lvl
379 %************************************************************************
381 \subsection{Utility bits for floating stats}
383 %************************************************************************
385 I didn't implement this with unboxed numbers. I don't want to be too
386 strict in this stuff, as it is rarely turned on. (WDP 95/09)
390 = FlS Int -- Number of top-floats * lambda groups they've been past
391 Int -- Number of non-top-floats * lambda groups they've been past
392 Int -- Number of lambda (groups) seen
394 get_stats (FlS a b c) = (a, b, c)
396 zero_stats = FlS 0 0 0
398 sum_stats xs = foldr add_stats zero_stats xs
400 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
401 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
403 add_to_stats (FlS a b c) floats
404 = FlS (a + length top_floats) (b + length other_floats) (c + 1)
406 (top_floats, other_floats) = partition to_very_top floats
408 to_very_top (my_lvl, _) = isTopLvl my_lvl
411 %************************************************************************
413 \subsection{Utility bits for floating}
415 %************************************************************************
418 getBindLevel (NonRec (_, lvl) _) = lvl
419 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
423 partitionByMajorLevel, partitionByLevel
424 :: Level -- Partitioning level
426 -> FloatingBinds -- Defns to be divided into 2 piles...
428 -> (FloatingBinds, -- Defns with level strictly < partition level,
429 FloatingBinds) -- The rest
432 partitionByMajorLevel ctxt_lvl defns
433 = partition float_further defns
435 float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
438 partitionByLevel ctxt_lvl defns
439 = partition float_further defns
441 float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
445 floatsToBinds :: FloatingBinds -> [CoreBinding]
446 floatsToBinds floats = map get_bind floats
448 get_bind (_, LetFloater bind) = bind
449 get_bind (_, CaseFloater _) = panic "floatsToBinds"
451 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
453 floatsToBindPairs floats = concat (map mk_pairs floats)
455 mk_pairs (_, LetFloater (Rec pairs)) = pairs
456 mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
457 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
459 install :: FloatingBinds -> CoreExpr -> CoreExpr
461 install defn_groups expr
462 = foldr install_group expr defn_groups
464 install_group (_, LetFloater defns) body = Let defns body
465 install_group (_, CaseFloater fn) body = fn body