2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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
13 IMPORT_Trace -- ToDo: rm (debugging)
19 import BasicLit ( BasicLit(..), PrimKind )
20 import CmdLineOpts ( GlobalSwitch(..) )
21 import CostCentre ( dupifyCC, CostCentre )
25 import Maybes ( Maybe(..), catMaybes, maybeToBool )
32 At the moment we never float a binding out to between two adjacent lambdas. For
35 \x y -> let t = x+x in ...
37 \x -> let t = x+x in \y -> ...
39 Reason: this is less efficient in the case where the original lambda is
40 never partially applied.
42 But there's a case I've seen where this might not be true. Consider:
48 elem' x (y:ys) = x==y || elem' x ys
50 It turns out that this generates a subexpression of the form
52 \deq x ys -> let eq = eqFromEqDict deq in ...
54 which might usefully be separated to
56 \deq -> let eq = eqFromEqDict deq in \xy -> ...
58 Well, maybe. We don't do this at the moment.
62 type LevelledExpr = CoreExpr (Id, Level) Id
63 type LevelledBind = CoreBinding (Id, Level) Id
64 type FloatingBind = (Level, Floater)
65 type FloatingBinds = [FloatingBind]
67 data Floater = LetFloater PlainCoreBinding
69 | CaseFloater (PlainCoreExpr -> PlainCoreExpr)
70 -- Give me a right-hand side of the
71 -- (usually single) alternative, and
72 -- I'll build the case
75 %************************************************************************
77 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
79 %************************************************************************
82 floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts
87 floatOutwards sw_chker us pgm
88 = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
90 case unzip (map (floatTopBind sw_chker) annotated_w_levels)
91 of { (fss, final_toplev_binds_s) ->
93 (if sw_chker D_verbose_core2core
94 then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
97 ( if not (sw_chker D_simplifier_stats) then
101 (tlets, ntlets, lams) = get_stats (sum_stats fss)
103 pprTrace "FloatOut stats: " (ppBesides [
104 ppInt tlets, ppStr " Lets floated to top level; ",
105 ppInt ntlets, ppStr " Lets floated elsewhere; from ",
106 ppInt lams, ppStr " Lambda groups"])
108 concat final_toplev_binds_s
111 floatTopBind sw bind@(CoNonRec _ _)
112 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
113 (fs, floatsToBinds floats ++ [bind'])
116 floatTopBind sw bind@(CoRec _)
117 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, CoRec pairs', _) ->
118 -- Actually floats will be empty
119 --false:ASSERT(null floats)
120 (fs, [CoRec (floatsToBindPairs floats ++ pairs')])
124 %************************************************************************
126 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
128 %************************************************************************
132 floatBind :: (GlobalSwitch -> Bool)
136 -> (FloatStats, FloatingBinds, PlainCoreBinding, IdEnv Level)
138 floatBind sw env lvl (CoNonRec (name,level) rhs)
139 = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
141 -- A good dumping point
142 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
144 (fs, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
147 floatBind sw env lvl bind@(CoRec 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, CoRec 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 CoRec (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 sw 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 :: (GlobalSwitch -> Bool)
201 -> (FloatStats, FloatingBinds, PlainCoreExpr)
203 floatExpr sw env _ (CoVar v) = (zero_stats, [], CoVar v)
205 floatExpr sw env _ (CoLit l) = (zero_stats, [], CoLit l)
207 floatExpr sw env _ (CoPrim op ty as) = (zero_stats, [], CoPrim op ty as)
208 floatExpr sw env _ (CoCon con ty as) = (zero_stats, [], CoCon con ty as)
210 floatExpr sw env lvl (CoApp e a)
211 = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
212 (fs, floating_defns, CoApp e' a) }
214 floatExpr sw env lvl (CoTyApp e ty)
215 = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
216 (fs, floating_defns, CoTyApp e' ty) }
218 floatExpr sw env lvl (CoTyLam tv e)
220 incd_lvl = incMinorLvl lvl
222 case (floatExpr sw env incd_lvl e) of { (fs, floats, e') ->
224 -- Dump any bindings which absolutely cannot go any further
225 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
227 (fs, floats', CoTyLam tv (install heres e'))
230 floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
233 new_env = growIdEnvList env args
235 case (floatExpr sw 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 mkCoLam args' (install heres rhs'))
245 floatExpr sw env lvl (CoSCC cc expr)
246 = case (floatExpr sw 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, CoSCC 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 (CoNonRec binder rhs))
261 = LetFloater (CoNonRec binder (ann_rhs rhs))
263 ann_bind (LetFloater (CoRec pairs))
264 = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
266 ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
268 ann_rhs (CoLam args e) = CoLam args (ann_rhs e)
269 ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
270 ann_rhs rhs@(CoCon _ _ _)= rhs -- no point in scc'ing WHNF data
271 ann_rhs rhs = CoSCC dupd_cc rhs
273 -- Note: Nested SCC's are preserved for the benefit of
274 -- cost centre stack profiling (Durham)
276 floatExpr sw env lvl (CoLet bind body)
277 = case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
278 case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
280 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
284 bind_lvl = getBindLevel bind
286 floatExpr sw env lvl (CoCase scrut alts)
287 = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
289 case (scrut', float_alts alts) of
291 {- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
293 (CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault))
294 | scrut_var_lvl `ltMajLvl` lvl ->
296 -- Candidate for case floater; scrutinising a variable; it can
297 -- escape outside a lambda; there's only one alternative.
298 (fda ++ fde ++ [case_floater], rhs')
301 case_floater = (scrut_var_lvl, CaseFloater fn)
302 fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
303 scrut_var_lvl = case lookupIdEnv env scrut_var of
305 Just lvl -> unTopify lvl
307 END OF CASE FLOATING DROPPED -}
309 (_, (fsa, fda, alts')) ->
311 (add_stats fse fsa, fda ++ fde, CoCase scrut' alts')
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 CoAlgAlts [_] CoNoDefault -> partitionByLevel
329 CoAlgAlts [] (CoBindDefault _ _) -> partitionByLevel
330 CoPrimAlts [_] CoNoDefault -> partitionByLevel
331 CoPrimAlts [] (CoBindDefault _ _) -> partitionByLevel
333 -- If there's more than one alternative, then
334 -- this is a dumping point
335 other -> partitionByMajorLevel
338 float_alts (CoAlgAlts 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 CoAlgAlts alts' deflt') }}
345 float_alts (CoPrimAlts 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 CoPrimAlts alts' deflt') }}
353 float_alg_alt (con, bs, rhs)
356 new_env = growIdEnvList env bs
358 case (floatExpr sw 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 sw 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 CoNoDefault = (zero_stats, [], CoNoDefault)
371 float_deflt (CoBindDefault (b,lvl) rhs)
372 = case (floatExpr sw 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', CoBindDefault 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 (CoNonRec (_, lvl) _) = lvl
419 getBindLevel (CoRec (((_,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 -> [PlainCoreBinding]
446 floatsToBinds floats = map get_bind floats
448 get_bind (_, LetFloater bind) = bind
449 get_bind (_, CaseFloater _) = panic "floatsToBinds"
451 floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
453 floatsToBindPairs floats = concat (map mk_pairs floats)
455 mk_pairs (_, LetFloater (CoRec pairs)) = pairs
456 mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
457 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
459 install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
461 install defn_groups expr
462 = foldr install_group expr defn_groups
464 install_group (_, LetFloater defns) body = CoLet defns body
465 install_group (_, CaseFloater fn) body = fn body