summaryrefslogtreecommitdiff
path: root/ghc/compiler/simplCore/FloatOut.lhs
blob: 000ed33dd3fc88551922f7bd0e3c453b2a555974 (plain)
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}