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 unzip3 (map (floatTopBind sw_chker) annotated_w_levels)
91 of { (fcs, lcs, final_toplev_binds_s) ->
93 (if sw_chker D_verbose_core2core
94 then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
97 ( if sw_chker D_simplifier_stats
98 then pprTrace "FloatOut stats: " (ppBesides [
99 ppInt (sum fcs), ppStr " Lets floated out of ",
100 ppInt (sum lcs), ppStr " Lambdas"])
103 concat final_toplev_binds_s
106 floatTopBind sw bind@(CoNonRec _ _)
107 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, bind', _) ->
108 (fc,lc, floatsToBinds floats ++ [bind'])
111 floatTopBind sw bind@(CoRec _)
112 = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, CoRec pairs', _) ->
113 -- Actually floats will be empty
114 --false:ASSERT(null floats)
115 (fc,lc, [CoRec (floatsToBindPairs floats ++ pairs')])
119 %************************************************************************
121 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
123 %************************************************************************
127 floatBind :: (GlobalSwitch -> Bool)
131 -> (Int,Int, FloatingBinds, PlainCoreBinding, IdEnv Level)
133 floatBind sw env lvl (CoNonRec (name,level) rhs)
134 = case (floatExpr sw env level rhs) of { (fc,lc, rhs_floats, rhs') ->
136 -- A good dumping point
137 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
139 (fc,lc, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
142 floatBind sw env lvl bind@(CoRec pairs)
143 = case (unzip4 (map do_pair pairs)) of { (fcs,lcs, rhss_floats, new_pairs) ->
145 if not (isTopLvl bind_level) then
147 (sum fcs,sum lcs, concat rhss_floats, CoRec new_pairs, new_env)
149 {- In a recursive binding, destined for the top level (only),
150 the rhs floats may contain
151 references to the bound things. For example
153 f = ...(let v = ...f... in b) ...
160 and hence we must (pessimistically) make all the floats recursive
161 with the top binding. Later dependency analysis will unravel it.
164 (sum fcs,sum lcs, [],
165 CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
170 new_env = growIdEnvList env (map fst pairs)
172 bind_level = getBindLevel bind
174 do_pair ((name, level), rhs)
175 = case (floatExpr sw new_env level rhs) of { (fc,lc, rhs_floats, rhs') ->
177 -- A good dumping point
178 case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
180 (fc,lc, rhs_floats', (name, install heres rhs'))
184 %************************************************************************
186 \subsection[FloatOut-Expr]{Floating in expressions}
188 %************************************************************************
191 floatExpr :: (GlobalSwitch -> Bool)
195 -> (Int,Int, FloatingBinds, PlainCoreExpr)
197 floatExpr sw env _ (CoVar v) = (0,0, [], CoVar v)
199 floatExpr sw env _ (CoLit l) = (0,0, [], CoLit l)
201 floatExpr sw env _ (CoPrim op ty as) = (0,0, [], CoPrim op ty as)
202 floatExpr sw env _ (CoCon con ty as) = (0,0, [], CoCon con ty as)
204 floatExpr sw env lvl (CoApp e a)
205 = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
206 (fc,lc, floating_defns, CoApp e' a) }
208 floatExpr sw env lvl (CoTyApp e ty)
209 = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
210 (fc,lc, floating_defns, CoTyApp e' ty) }
212 floatExpr sw env lvl (CoTyLam tv e)
214 incd_lvl = incMinorLvl lvl
216 case (floatExpr sw env incd_lvl e) of { (fc,lc, floats, e') ->
218 -- Dump any bindings which absolutely cannot go any further
219 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
221 (fc,lc, floats', CoTyLam tv (install heres e'))
224 floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
227 new_env = growIdEnvList env args
229 case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, floats, rhs') ->
231 -- Dump any bindings which absolutely cannot go any further
232 case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
234 (fc + length floats', lc + 1,
235 floats', mkCoLam args' (install heres rhs'))
238 floatExpr sw env lvl (CoSCC cc expr)
239 = case (floatExpr sw env lvl expr) of { (fc,lc, floating_defns, expr') ->
241 -- annotate bindings floated outwards past an scc expression
242 -- with the cc. We mark that cc as "duplicated", though.
244 annotated_defns = annotate (dupifyCC cc) floating_defns
246 (fc,lc, annotated_defns, CoSCC cc expr') }
248 annotate :: CostCentre -> FloatingBinds -> FloatingBinds
250 annotate dupd_cc defn_groups
251 = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
253 ann_bind (LetFloater (CoNonRec binder rhs))
254 = LetFloater (CoNonRec binder (ann_rhs rhs))
256 ann_bind (LetFloater (CoRec pairs))
257 = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
259 ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
261 ann_rhs (CoLam args e) = CoLam args (ann_rhs e)
262 ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
263 ann_rhs rhs@(CoCon _ _ _)= rhs -- no point in scc'ing WHNF data
264 ann_rhs rhs = CoSCC dupd_cc rhs
266 -- Note: Nested SCC's are preserved for the benefit of
267 -- cost centre stack profiling (Durham)
269 floatExpr sw env lvl (CoLet bind body)
270 = case (floatBind sw env lvl bind) of { (fcb,lcb, rhs_floats, bind', new_env) ->
271 case (floatExpr sw new_env lvl body) of { (fce,lce, body_floats, body') ->
272 (fcb + fce, lcb + lce,
273 rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats, body')
276 bind_lvl = getBindLevel bind
278 floatExpr sw env lvl (CoCase scrut alts)
279 = case (floatExpr sw env lvl scrut) of { (fce,lce, fde, scrut') ->
281 case (scrut', float_alts alts) of
283 {- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
285 (CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault))
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 = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
295 scrut_var_lvl = case lookupIdEnv env scrut_var of
297 Just lvl -> unTopify lvl
299 END OF CASE FLOATING DROPPED -}
301 (_, (fca,lca, fda, alts')) ->
303 (fce + fca, lce + lca, fda ++ fde, CoCase 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 CoAlgAlts [_] CoNoDefault -> partitionByLevel
321 CoAlgAlts [] (CoBindDefault _ _) -> partitionByLevel
322 CoPrimAlts [_] CoNoDefault -> partitionByLevel
323 CoPrimAlts [] (CoBindDefault _ _) -> partitionByLevel
325 -- If there's more than one alternative, then
326 -- this is a dumping point
327 other -> partitionByMajorLevel
330 float_alts (CoAlgAlts alts deflt)
331 = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') ->
332 case (unzip4 (map float_alg_alt alts)) of { (fcas,lcas, fdas, alts') ->
333 (fcd + sum fcas, lcd + sum lcas,
334 concat fdas ++ fdd, CoAlgAlts alts' deflt') }}
336 float_alts (CoPrimAlts alts deflt)
337 = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') ->
338 case (unzip4 (map float_prim_alt alts)) of { (fcas,lcas, fdas, alts') ->
339 (fcd + sum fcas, lcd + sum lcas,
340 concat fdas ++ fdd, CoPrimAlts alts' deflt') }}
343 float_alg_alt (con, bs, rhs)
346 new_env = growIdEnvList env bs
348 case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
349 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
350 (fc, lc, rhs_floats', (con, bs', install heres rhs'))
354 float_prim_alt (lit, rhs)
355 = case (floatExpr sw env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
356 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
357 (fc,lc, rhs_floats', (lit, install heres rhs'))
361 float_deflt CoNoDefault = (0,0, [], CoNoDefault)
363 float_deflt (CoBindDefault (b,lvl) rhs)
364 = case (floatExpr sw new_env lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
365 case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
366 (fc,lc, rhs_floats', CoBindDefault b (install heres rhs'))
369 new_env = addOneToIdEnv env b lvl
372 %************************************************************************
374 \subsection[FloatOut-utils]{Utility bits for floating}
376 %************************************************************************
379 getBindLevel (CoNonRec (_, lvl) _) = lvl
380 getBindLevel (CoRec (((_,lvl), _) : _)) = lvl
384 partitionByMajorLevel, partitionByLevel
385 :: Level -- Partitioning level
387 -> FloatingBinds -- Defns to be divided into 2 piles...
389 -> (FloatingBinds, -- Defns with level strictly < partition level,
390 FloatingBinds) -- The rest
393 partitionByMajorLevel ctxt_lvl defns
394 = partition float_further defns
396 float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
399 partitionByLevel ctxt_lvl defns
400 = partition float_further defns
402 float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
406 floatsToBinds :: FloatingBinds -> [PlainCoreBinding]
407 floatsToBinds floats = map get_bind floats
409 get_bind (_, LetFloater bind) = bind
410 get_bind (_, CaseFloater _) = panic "floatsToBinds"
412 floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
414 floatsToBindPairs floats = concat (map mk_pairs floats)
416 mk_pairs (_, LetFloater (CoRec pairs)) = pairs
417 mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
418 mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
420 install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
422 install defn_groups expr
423 = foldr install_group expr defn_groups
425 install_group (_, LetFloater defns) body = CoLet defns body
426 install_group (_, CaseFloater fn) body = fn body