ghc-hack /compiler/simplCore/CSE.lhs

Language Haskell Lines 425
MD5 Hash e996b5c4214509bde79af840424ef7c1 Estimated Cost $4,464 (why?)
Repository https://bitbucket.org/khibino/ghc-hack View Raw File View Project SPDX
  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
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section{Common subexpression}

\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

module CSE (
	cseProgram
    ) where

#include "HsVersions.h"

-- Note [Keep old CSEnv rep]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- Temporarily retain code for the old representation for CSEnv
-- Keeping it only so that we can switch back if a bug shows up
-- or we want to do some performance comparisions
--
-- NB: when you remove this, also delete hashExpr from CoreUtils
#ifdef OLD_CSENV_REP
import CoreUtils        ( exprIsBig, hashExpr, eqExpr )
import StaticFlags	( opt_PprStyle_Debug )
import Util		( lengthExceeds )
import UniqFM
import FastString
#else
import TrieMap
#endif

import CoreSubst
import Var		( Var )
import Id		( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils	( mkAltExpr
                        , exprIsTrivial, exprIsCheap )
import DataCon		( isUnboxedTupleCon )
import Type		( tyConAppArgs )
import CoreSyn
import Outputable
import BasicTypes	( isAlwaysActive )

import Data.List
\end{code}


			Simple common sub-expression
			~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
	x1 = C a b
	x2 = C x1 b
we build up a reverse mapping:   C a b  -> x1
				 C x1 b -> x2
and apply that to the rest of the program.

When we then see
	y1 = C a b
	y2 = C y1 b
we replace the C a b with x1.  But then we *dont* want to
add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
so that a subsequent binding
	y2 = C y1 b
will get transformed to C x1 b, and then to x2.  

So we carry an extra var->var substitution which we apply *before* looking up in the
reverse mapping.


Note [Shadowing]
~~~~~~~~~~~~~~~~
We have to be careful about shadowing.
For example, consider
	f = \x -> let y = x+x in
	              h = \x -> x+x
	          in ...

Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
We can simply add clones to the substitution already described.

Note [Case binders 1]
~~~~~~~~~~~~~~~~~~~~~~
Consider

	f = \x -> case x of wild { 
			(a:as) -> case a of wild1 {
				    (p,q) -> ...(wild1:as)...

Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
But that's not quite obvious.  In general we want to keep it as (wild1:as),
but for CSE purpose that's a bad idea.

So we add the binding (wild1 -> a) to the extra var->var mapping.
Notice this is exactly backwards to what the simplifier does, which is
to try to replaces uses of 'a' with uses of 'wild1'

Note [Case binders 2]
~~~~~~~~~~~~~~~~~~~~~~
Consider
	case (h x) of y -> ...(h x)...

We'd like to replace (h x) in the alternative, by y.  But because of
the preceding [Note: case binders 1], we only want to add the mapping
	scrutinee -> case binder
to the reverse CSE mapping if the scrutinee is a non-trivial expression.
(If the scrutinee is a simple variable we want to add the mapping
	case binder -> scrutinee 
to the substitution

Note [Unboxed tuple case binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
	case f x of t { (# a,b #) -> 
	case ... of
	  True -> f x
	  False -> 0 }

We must not replace (f x) by t, because t is an unboxed-tuple binder.
Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is
	f x --> (# a,b #)
That is why the CSEMap has pairs of expressions.

Note [CSE for INLINE and NOINLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful to do no CSE inside functions that the user has marked as
INLINE or NOINLINE.  In terms of Core, that means 

	a) we do not do CSE inside an InlineRule

	b) we do not do CSE on the RHS of a binding b=e
	   unless b's InlinePragma is AlwaysActive

Here's why (examples from Roman Leshchinskiy).  Consider

	yes :: Int
	{-# NOINLINE yes #-}
	yes = undefined

	no :: Int
	{-# NOINLINE no #-}
	no = undefined

	foo :: Int -> Int -> Int
	{-# NOINLINE foo #-}
	foo m n = n

	{-# RULES "foo/no" foo no = id #-}

	bar :: Int -> Int
	bar = foo yes

We do not expect the rule to fire.  But if we do CSE, then we get
yes=no, and the rule does fire.  Worse, whether we get yes=no or
no=yes depends on the order of the definitions.

In general, CSE should probably never touch things with INLINE pragmas
as this could lead to surprising results.  Consider

	{-# INLINE foo #-}
	foo = <rhs>

	{-# NOINLINE bar #-}
	bar = <rhs>	-- Same rhs as foo

If CSE produces
	foo = bar
then foo will never be inlined (when it should be); but if it produces
	bar = foo
bar will be inlined (when it should not be). Even if we remove INLINE foo,
we'd still like foo to be inlined if rhs is small. This won't happen
with foo = bar.

Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
a worker/wrapper, in which the worker has turned into a single variable:
	$wf = h
	f = \x -> ...$wf...
Now CSE may transform to
	f = \x -> ...h...
But the WorkerInfo for f still says $wf, which is now dead!  This won't
happen now that we don't look inside INLINEs (which wrappers are).


%************************************************************************
%*									*
\section{Common subexpression}
%*									*
%************************************************************************

\begin{code}
cseProgram :: CoreProgram -> CoreProgram
cseProgram binds = cseBinds emptyCSEnv binds

cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
cseBinds _   []     = []
cseBinds env (b:bs) = (b':bs')
		    where
		      (env1, b') = cseBind  env  b
		      bs'        = cseBinds env1 bs

cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
cseBind env (NonRec b e) 
  = (env2, NonRec b' e')
  where
    (env1, b') = addBinder env b
    (env2, e') = cseRhs env1 (b',e)

cseBind env (Rec pairs)
  = (env2, Rec (bs' `zip` es'))
  where
    (bs,es) = unzip pairs
    (env1, bs') = addRecBinders env bs
    (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)

cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
cseRhs env (id',rhs)
  = case lookupCSEnv env rhs' of
	Just other_expr     -> (env, 			         other_expr)
	Nothing             -> (addCSEnvItem env rhs' (Var id'), rhs')
  where
    rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs
	 | otherwise			           = rhs
		-- See Note [CSE for INLINE and NOINLINE]

tryForCSE :: CSEnv -> InExpr -> OutExpr
tryForCSE env expr
  | exprIsTrivial expr'                   = expr'	-- No point
  | Just smaller <- lookupCSEnv env expr' = smaller
  | otherwise                             = expr'
  where
    expr' = cseExpr env expr

cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t)               = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c)           = Coercion (substCo (csEnvSubst env) c)
cseExpr _   (Lit lit)              = Lit lit
cseExpr env (Var v)		   = lookupSubst env v
cseExpr env (App f a)        	   = App (cseExpr env f) (tryForCSE env a)
cseExpr env (Tick t e)           = Tick t (cseExpr env e)
cseExpr env (Cast e co)            = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
cseExpr env (Lam b e)	     	   = let (env', b') = addBinder env b
				     in Lam b' (cseExpr env' e)
cseExpr env (Let bind e)    	   = let (env', bind') = cseBind env bind
				     in Let bind' (cseExpr env' e)
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
				   where
                                     alts' = cseAlts env' scrut' bndr bndr'' alts
				     scrut' = tryForCSE env scrut
				     (env', bndr') = addBinder env bndr
				     bndr'' = zapIdOccInfo bndr'
					-- The swizzling from Note [Case binders 2] may
					-- cause a dead case binder to be alive, so we
					-- play safe here and bring them all to life

cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]

cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
  | isUnboxedTupleCon con
	-- Unboxed tuples are special because the case binder isn't
	-- a real value.  See Note [Unboxed tuple case binders]
  = [(DataAlt con, args'', tryForCSE new_env rhs)]
  where
    (env', args') = addBinders env args
    args'' = map zapIdOccInfo args'	-- They should all be ids
	-- Same motivation for zapping as [Case binders 2] only this time
	-- it's Note [Unboxed tuple case binders]
    new_env | exprIsCheap scrut' = env'
	    | otherwise 	 = extendCSEnv env' scrut' tup_value
    tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))

cseAlts env scrut' bndr bndr' alts
  = map cse_alt alts
  where
    (con_target, alt_env)
	= case scrut' of
	    Var v' -> (v',     extendCSSubst env bndr v')	-- See Note [Case binders 1]
								-- map: bndr -> v'

	    _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]
								    -- map: scrut' -> bndr'

    arg_tys = tyConAppArgs (idType bndr)

    cse_alt (DataAlt con, args, rhs)
	| not (null args)
		-- Don't try CSE if there are no args; it just increases the number
		-- of live vars.  E.g.
		--	case x of { True -> ....True.... }
		-- Don't replace True by x!  
		-- Hence the 'null args', which also deal with literals and DEFAULT
	= (DataAlt con, args', tryForCSE new_env rhs)
	where
	  (env', args') = addBinders alt_env args
	  new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
					   (Var con_target)

    cse_alt (con, args, rhs)
	= (con, args', tryForCSE env' rhs)
	where
	  (env', args') = addBinders alt_env args
\end{code}


%************************************************************************
%*									*
\section{The CSE envt}
%*									*
%************************************************************************

\begin{code}
type InExpr  = CoreExpr		-- Pre-cloning
type InBndr  = CoreBndr
type InAlt   = CoreAlt

type OutExpr  = CoreExpr	-- Post-cloning
type OutBndr  = CoreBndr
type OutAlt   = CoreAlt

-- See Note [Keep old CsEnv rep]
#ifdef OLD_CSENV_REP
data CSEnv  = CS { cs_map    :: CSEMap
                 , cs_subst  :: Subst }

type CSEMap = UniqFM [(OutExpr, OutExpr)]	-- This is the reverse mapping
	-- It maps the hash-code of an expression e to list of (e,e') pairs
	-- This means that it's good to replace e by e'
	-- INVARIANT: The expr in the range has already been CSE'd

emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst }

lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr
  = case lookupUFM oldmap (hashExpr expr) of
             	Nothing -> Nothing
         	Just pairs -> lookup_list pairs
  where
    in_scope = substInScope sub

  -- In this lookup we use full expression equality
  -- Reason: when expressions differ we generally find out quickly
  --         but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
  -- 	     and this kind of thing happened in real programs
    lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr
    lookup_list ((e,e'):es) 
      | eqExpr in_scope e expr = Just e'
      | otherwise	                 = lookup_list es
    lookup_list []                       = Nothing

addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
addCSEnvItem env expr expr' | exprIsBig expr = env
			    | otherwise      = extendCSEnv env expr expr'
   -- We don't try to CSE big expressions, because they are expensive to compare
   -- (and are unlikely to be the same anyway)

extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse@(CS { cs_map = oldmap }) expr expr'
  = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] }
  where
    hash = hashExpr expr
    combine old new 
	= WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
	where
	  result = new ++ old
	  short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
	  long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
		   | otherwise	        = empty

#else
------------ NEW ----------------

data CSEnv  = CS { cs_map    :: CoreMap (OutExpr, OutExpr)   -- Key, value
                 , cs_subst  :: Subst }

emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }

lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS { cs_map = csmap }) expr 
  = case lookupCoreMap csmap expr of
      Just (_,e) -> Just e
      Nothing    -> Nothing

addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
addCSEnvItem = extendCSEnv
   -- We used to avoid trying to CSE big expressions, on the grounds
   -- that they are expensive to compare.  But now we have CoreMaps
   -- we can happily insert them and laziness will mean that the
   -- insertions only get fully done if we look up in that part
   -- of the trie. No need for a size test.

extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse expr expr'
  = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') }
#endif

csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

lookupSubst :: CSEnv -> Id -> OutExpr
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x

extendCSSubst :: CSEnv -> Id  -> Id -> CSEnv
extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }

addBinder :: CSEnv -> Var -> (CSEnv, Var)
addBinder cse v = (cse { cs_subst = sub' }, v') 
                where
                  (sub', v') = substBndr (cs_subst cse) v

addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
addBinders cse vs = (cse { cs_subst = sub' }, vs') 
                where
                  (sub', vs') = substBndrs (cs_subst cse) vs

addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
addRecBinders cse vs = (cse { cs_subst = sub' }, vs') 
                where
                  (sub', vs') = substRecBndrs (cs_subst cse) vs
\end{code}
Back to Top