1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[FloatOut]{Float bindings outwards (towards the top level)}
``Long-distance'' floating of bindings towards the top level.
\begin{code}
#include "HsVersions.h"
module FloatOut ( floatOutwards ) where
import Literal ( Literal(..) )
import CmdLineOpts ( GlobalSwitch(..) )
import CostCentre ( dupifyCC, CostCentre )
import SetLevels
import Id ( eqId )
import Maybes ( Maybe(..), catMaybes, maybeToBool )
import UniqSupply
import Util
\end{code}
Random comments
~~~~~~~~~~~~~~~
At the moment we never float a binding out to between two adjacent lambdas. For
example:
@
\x y -> let t = x+x in ...
===>
\x -> let t = x+x in \y -> ...
@
Reason: this is less efficient in the case where the original lambda is
never partially applied.
But there's a case I've seen where this might not be true. Consider:
@
elEm2 x ys
= elem' x ys
where
elem' _ [] = False
elem' x (y:ys) = x==y || elem' x ys
@
It turns out that this generates a subexpression of the form
@
\deq x ys -> let eq = eqFromEqDict deq in ...
@
which might usefully be separated to
@
\deq -> let eq = eqFromEqDict deq in \xy -> ...
@
Well, maybe. We don't do this at the moment.
\begin{code}
type LevelledExpr = GenCoreExpr (Id, Level) Id
type LevelledBind = GenCoreBinding (Id, Level) Id
type FloatingBind = (Level, Floater)
type FloatingBinds = [FloatingBind]
data Floater = LetFloater CoreBinding
| CaseFloater (CoreExpr -> CoreExpr)
-- Give me a right-hand side of the
-- (usually single) alternative, and
-- I'll build the case
\end{code}
%************************************************************************
%* *
\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
%* *
%************************************************************************
\begin{code}
floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts
-> UniqSupply
-> [CoreBinding]
-> [CoreBinding]
floatOutwards sw_chker us pgm
= case (setLevels pgm sw_chker us) of { annotated_w_levels ->
case unzip (map (floatTopBind sw_chker) annotated_w_levels)
of { (fss, final_toplev_binds_s) ->
(if sw_chker D_verbose_core2core
then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
else id
)
( if not (sw_chker D_simplifier_stats) then
id
else
let
(tlets, ntlets, lams) = get_stats (sum_stats fss)
in
pprTrace "FloatOut stats: " (ppBesides [
ppInt tlets, ppStr " Lets floated to top level; ",
ppInt ntlets, ppStr " Lets floated elsewhere; from ",
ppInt lams, ppStr " Lambda groups"])
)
concat final_toplev_binds_s
}}
floatTopBind sw bind@(NonRec _ _)
= case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
(fs, floatsToBinds floats ++ [bind'])
}
floatTopBind sw bind@(Rec _)
= case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
-- Actually floats will be empty
--false:ASSERT(null floats)
(fs, [Rec (floatsToBindPairs floats ++ pairs')])
}
\end{code}
%************************************************************************
%* *
\subsection[FloatOut-Bind]{Floating in a binding (the business end)}
%* *
%************************************************************************
\begin{code}
floatBind :: (GlobalSwitch -> Bool)
-> IdEnv Level
-> Level
-> LevelledBind
-> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
floatBind sw env lvl (NonRec (name,level) rhs)
= case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
}}
floatBind sw env lvl bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then
-- Standard case
(sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
else
{- In a recursive binding, destined for the top level (only),
the rhs floats may contain
references to the bound things. For example
f = ...(let v = ...f... in b) ...
might get floated to
v = ...f...
f = ... b ...
and hence we must (pessimistically) make all the floats recursive
with the top binding. Later dependency analysis will unravel it.
-}
(sum_stats fss,
[],
Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
new_env)
}
where
new_env = growIdEnvList env (map fst pairs)
bind_level = getBindLevel bind
do_pair ((name, level), rhs)
= case (floatExpr sw new_env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (name, install heres rhs'))
}}
\end{code}
%************************************************************************
\subsection[FloatOut-Expr]{Floating in expressions}
%* *
%************************************************************************
\begin{code}
floatExpr :: (GlobalSwitch -> Bool)
-> IdEnv Level
-> Level
-> LevelledExpr
-> (FloatStats, FloatingBinds, CoreExpr)
floatExpr sw env _ (Var v) = (zero_stats, [], Var v)
floatExpr sw env _ (Lit l) = (zero_stats, [], Lit l)
floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
floatExpr sw env lvl (App e a)
= case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
(fs, floating_defns, App e' a) }
floatExpr sw env lvl (CoTyApp e ty)
= case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
(fs, floating_defns, CoTyApp e' ty) }
floatExpr sw env lvl (CoTyLam tv e)
= let
incd_lvl = incMinorLvl lvl
in
case (floatExpr sw env incd_lvl e) of { (fs, floats, e') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
(fs, floats', CoTyLam tv (install heres e'))
}}
floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
= let
new_env = addOneToIdEnv env arg incd_lvl
in
case (floatExpr sw new_env incd_lvl rhs) of { (fs, floats, rhs') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
(add_to_stats fs floats',
floats',
Lam args' (install heres rhs'))
}}
floatExpr sw env lvl (SCC cc expr)
= case (floatExpr sw env lvl expr) of { (fs, floating_defns, expr') ->
let
-- annotate bindings floated outwards past an scc expression
-- with the cc. We mark that cc as "duplicated", though.
annotated_defns = annotate (dupifyCC cc) floating_defns
in
(fs, annotated_defns, SCC cc expr') }
where
annotate :: CostCentre -> FloatingBinds -> FloatingBinds
annotate dupd_cc defn_groups
= [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
where
ann_bind (LetFloater (NonRec binder rhs))
= LetFloater (NonRec binder (ann_rhs rhs))
ann_bind (LetFloater (Rec pairs))
= LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
ann_rhs rhs@(Con _ _ _)= rhs -- no point in scc'ing WHNF data
ann_rhs rhs = SCC dupd_cc rhs
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
floatExpr sw env lvl (Let bind body)
= case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
(add_stats fsb fse,
rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
body')
}}
where
bind_lvl = getBindLevel bind
floatExpr sw env lvl (Case scrut alts)
= case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
case (scrut', float_alts alts) of
{- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
(Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
| scrut_var_lvl `ltMajLvl` lvl ->
-- Candidate for case floater; scrutinising a variable; it can
-- escape outside a lambda; there's only one alternative.
(fda ++ fde ++ [case_floater], rhs')
where
case_floater = (scrut_var_lvl, CaseFloater fn)
fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
scrut_var_lvl = case lookupIdEnv env scrut_var of
Nothing -> Level 0 0
Just lvl -> unTopify lvl
END OF CASE FLOATING DROPPED -}
(_, (fsa, fda, alts')) ->
(add_stats fse fsa, fda ++ fde, Case scrut' alts')
}
where
incd_lvl = incMinorLvl lvl
partition_fn = partitionByMajorLevel
{- OMITTED
We don't want to be too keen about floating lets out of case alternatives
because they may benefit from seeing the evaluation done by the case.
The main reason for doing this is to allocate in fewer larger blocks
but that's really an STG-level issue.
case alts of
-- Just one alternative, then dump only
-- what *has* to be dumped
AlgAlts [_] NoDefault -> partitionByLevel
AlgAlts [] (BindDefault _ _) -> partitionByLevel
PrimAlts [_] NoDefault -> partitionByLevel
PrimAlts [] (BindDefault _ _) -> partitionByLevel
-- If there's more than one alternative, then
-- this is a dumping point
other -> partitionByMajorLevel
-}
float_alts (AlgAlts alts deflt)
= case (float_deflt deflt) of { (fsd, fdd, deflt') ->
case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
(foldr add_stats fsd fsas,
concat fdas ++ fdd,
AlgAlts alts' deflt') }}
float_alts (PrimAlts alts deflt)
= case (float_deflt deflt) of { (fsd, fdd, deflt') ->
case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
(foldr add_stats fsd fsas,
concat fdas ++ fdd,
PrimAlts alts' deflt') }}
-------------
float_alg_alt (con, bs, rhs)
= let
bs' = map fst bs
new_env = growIdEnvList env bs
in
case (floatExpr sw new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (con, bs', install heres rhs')) }}
--------------
float_prim_alt (lit, rhs)
= case (floatExpr sw env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (lit, install heres rhs')) }}
--------------
float_deflt NoDefault = (zero_stats, [], NoDefault)
float_deflt (BindDefault (b,lvl) rhs)
= case (floatExpr sw new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', BindDefault b (install heres rhs')) }}
where
new_env = addOneToIdEnv env b lvl
\end{code}
%************************************************************************
%* *
\subsection{Utility bits for floating stats}
%* *
%************************************************************************
I didn't implement this with unboxed numbers. I don't want to be too
strict in this stuff, as it is rarely turned on. (WDP 95/09)
\begin{code}
data FloatStats
= FlS Int -- Number of top-floats * lambda groups they've been past
Int -- Number of non-top-floats * lambda groups they've been past
Int -- Number of lambda (groups) seen
get_stats (FlS a b c) = (a, b, c)
zero_stats = FlS 0 0 0
sum_stats xs = foldr add_stats zero_stats xs
add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
= FlS (a1 + a2) (b1 + b2) (c1 + c2)
add_to_stats (FlS a b c) floats
= FlS (a + length top_floats) (b + length other_floats) (c + 1)
where
(top_floats, other_floats) = partition to_very_top floats
to_very_top (my_lvl, _) = isTopLvl my_lvl
\end{code}
%************************************************************************
%* *
\subsection{Utility bits for floating}
%* *
%************************************************************************
\begin{code}
getBindLevel (NonRec (_, lvl) _) = lvl
getBindLevel (Rec (((_,lvl), _) : _)) = lvl
\end{code}
\begin{code}
partitionByMajorLevel, partitionByLevel
:: Level -- Partitioning level
-> FloatingBinds -- Defns to be divided into 2 piles...
-> (FloatingBinds, -- Defns with level strictly < partition level,
FloatingBinds) -- The rest
partitionByMajorLevel ctxt_lvl defns
= partition float_further defns
where
float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
isTopLvl my_lvl
partitionByLevel ctxt_lvl defns
= partition float_further defns
where
float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
\end{code}
\begin{code}
floatsToBinds :: FloatingBinds -> [CoreBinding]
floatsToBinds floats = map get_bind floats
where
get_bind (_, LetFloater bind) = bind
get_bind (_, CaseFloater _) = panic "floatsToBinds"
floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
floatsToBindPairs floats = concat (map mk_pairs floats)
where
mk_pairs (_, LetFloater (Rec pairs)) = pairs
mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
install :: FloatingBinds -> CoreExpr -> CoreExpr
install defn_groups expr
= foldr install_group expr defn_groups
where
install_group (_, LetFloater defns) body = Let defns body
install_group (_, CaseFloater fn) body = fn body
\end{code}
|