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
13 import Literal ( Literal(..) )
14 import CmdLineOpts ( GlobalSwitch(..) )
15 import CostCentre ( dupifyCC, CostCentre )
18 import Maybes ( Maybe(..), catMaybes, maybeToBool )
25 At the moment we never float a binding out to between two adjacent lambdas. For
28 \x y -> let t = x+x in ...
30 \x -> let t = x+x in \y -> ...
32 Reason: this is less efficient in the case where the original lambda is
33 never partially applied.
35 But there's a case I've seen where this might not be true. Consider:
41 elem' x (y:ys) = x==y || elem' x ys
43 It turns out that this generates a subexpression of the form
45 \deq x ys -> let eq = eqFromEqDict deq in ...
47 which might usefully be separated to
49 \deq -> let eq = eqFromEqDict deq in \xy -> ...
51 Well, maybe. We don't do this at the moment.
55 type LevelledExpr = GenCoreExpr (Id, Level) Id
56 type LevelledBind = GenCoreBinding (Id, Level) Id
57 type FloatingBind = (Level, Floater)
58 type FloatingBinds = [FloatingBind]
60 data Floater = LetFloater CoreBinding
62 | CaseFloater (CoreExpr -> CoreExpr)
63 -- Give me a right-hand side of the
64 -- (usually single) alternative, and
65 -- I'll build the case
68 %************************************************************************
70 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
72 %************************************************************************
75 floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts
80 floatOutwards sw_chker us pgm
81 = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
83 case unzip (map (floatTopBind sw_chker) annotated_w_levels)
84 of { (fss, final_toplev_binds_s) ->
86 (if sw_chker D_verbose_core2core
87 then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
90 ( if not (sw_chker D_simplifier_stats) then
94 (tlets, ntlets, lams) = get_stats (sum_stats fss)
96 pprTrace "FloatOut stats: " (ppBesides [
97 ppInt tlets, ppStr " Lets floated to top level; ",
98 ppInt ntlets, ppStr " Lets floated elsewhere; from ",
99 ppInt lams, ppStr " Lambda groups"])
101 concat final_toplev_binds_s
104 floatTopBind sw bind@(NonRec _ _)
105 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
106 (fs, floatsToBinds floats ++ [bind'])
109 floatTopBind sw bind@(Rec _)
110 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
111 -- Actually floats will be empty
112 --false:ASSERT(null floats)
113 (fs, [Rec (floatsToBindPairs floats ++ pairs')])
117 %************************************************************************
119 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
121 %************************************************************************
125 floatBind :: (GlobalSwitch -> Bool)
129 -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
131 floatBind sw env lvl (NonRec (name,level) rhs)
132 = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
134 -- A good dumping point
135 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
137 (fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
140 floatBind sw env lvl bind@(Rec pairs)
141 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
143 if not (isTopLvl bind_level) then
145 (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
147 {- In a recursive binding, destined for the top level (only),
148 the rhs floats may contain
149 references to the bound things. For example
151 f = ...(let v = ...f... in b) ...
158 and hence we must (pessimistically) make all the floats recursive
159 with the top binding. Later dependency analysis will unravel it.
164 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
169 new_env = growIdEnvList env (map fst pairs)
171 bind_level = getBindLevel bind
173 do_pair ((name, level), rhs)
174 = case (floatExpr sw new_env level rhs) of { (fs, rhs_floats, rhs') ->
176 -- A good dumping point
177 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
179 (fs, rhs_floats', (name, install heres rhs'))
183 %************************************************************************
185 \subsection[FloatOut-Expr]{Floating in expressions}
187 %************************************************************************
190 floatExpr :: (GlobalSwitch -> Bool)
194 -> (FloatStats, FloatingBinds, CoreExpr)
196 floatExpr sw env _ (Var v) = (zero_stats, [], Var v)
198 floatExpr sw env _ (Lit l) = (zero_stats, [], Lit l)
200 floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
201 floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
203 floatExpr sw env lvl (App e a)
204 = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
205 (fs, floating_defns, App e' a) }
207 floatExpr sw env lvl (CoTyApp e ty)
208 = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
209 (fs, floating_defns, CoTyApp e' ty) }
211 floatExpr sw env lvl (CoTyLam tv e)
213 incd_lvl = incMinorLvl lvl
215 case (floatExpr sw 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', CoTyLam tv (install heres e'))
223 floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
225 new_env = addOneToIdEnv env arg incd_lvl
227 case (floatExpr sw 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 args' (install heres rhs'))
237 floatExpr sw env lvl (SCC cc expr)
238 = case (floatExpr sw 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, SCC cc 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 -> SCC dupd_cc (fn rhs) )
260 ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
261 ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
262 ann_rhs rhs@(Con _ _ _)= rhs -- no point in scc'ing WHNF data
263 ann_rhs rhs = SCC dupd_cc rhs
265 -- Note: Nested SCC's are preserved for the benefit of
266 -- cost centre stack profiling (Durham)
268 floatExpr sw env lvl (Let bind body)
269 = case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
270 case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
272 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
276 bind_lvl = getBindLevel bind
278 floatExpr sw env lvl (Case scrut alts)
279 = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
281 case (scrut', float_alts alts) of
283 {- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
285 (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
286 | scrut_var_lvl `ltMajLvl` lvl ->
288 -- Candidate for case floater; scrutinising a variable; it can
289 -- escape outside a lambda; there's only one alternative.
290 (fda ++ fde ++ [case_floater], rhs')
293 case_floater = (scrut_var_lvl, CaseFloater fn)
294 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
295 scrut_var_lvl = case lookupIdEnv env scrut_var of
297 Just lvl -> unTopify lvl
299 END OF CASE FLOATING DROPPED -}
301 (_, (fsa, fda, alts')) ->
303 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
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 sw 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 sw 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 sw 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