From 6abe52739ffd8ea8e8d8b18f65d98fb88783e88c Mon Sep 17 00:00:00 2001
From: Michal Terepeta <michal.terepeta@gmail.com>
Date: Sun, 11 Dec 2011 09:20:26 +0100
Subject: [PATCH 1/3] Whitespace/layout only in simplCore/CSE.

compiler/simplCore/CSE.lhs  274 +++++++++++++++++++++
1 files changed, 132 insertions(+), 142 deletions()
diff git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 4a92f81..a1f6d8f 100644
a

b


4  4  \section{Common subexpression} 
5  5  
6  6  \begin{code} 
7   {# OPTIONS fnowarntabs #} 
8    The above warning supression flag is a temporary kludge. 
9    While working on this module you are encouraged to remove it and 
10    detab the module (please do the detabbing in a separate patch). See 
11    http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces 
12    for details 
13   
14   module CSE ( 
15   cseProgram 
16   ) where 
 7  module CSE ( cseProgram ) where 
17  8  
18  9  #include "HsVersions.h" 
19  10  
… 
… 
module CSE ( 
26  17   NB: when you remove this, also delete hashExpr from CoreUtils 
27  18  #ifdef OLD_CSENV_REP 
28  19  import CoreUtils ( exprIsBig, hashExpr, eqExpr ) 
29   import StaticFlags ( opt_PprStyle_Debug ) 
30   import Util ( lengthExceeds ) 
 20  import StaticFlags ( opt_PprStyle_Debug ) 
 21  import Util ( lengthExceeds ) 
31  22  import UniqFM 
32  23  import FastString 
33  24  #else 
… 
… 
import TrieMap 
35  26  #endif 
36  27  
37  28  import CoreSubst 
38   import Var ( Var ) 
39   import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) 
40   import CoreUtils ( mkAltExpr 
41   , exprIsTrivial, exprIsCheap ) 
42   import DataCon ( isUnboxedTupleCon ) 
43   import Type ( tyConAppArgs ) 
 29  import Var ( Var ) 
 30  import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) 
 31  import CoreUtils ( mkAltExpr, exprIsTrivial, exprIsCheap ) 
 32  import DataCon ( isUnboxedTupleCon ) 
 33  import Type ( tyConAppArgs ) 
44  34  import CoreSyn 
45  35  import Outputable 
46   import BasicTypes ( isAlwaysActive ) 
 36  import BasicTypes ( isAlwaysActive ) 
47  37  
48  38  import Data.List 
49  39  \end{code} 
50  40  
51  41  
52   Simple common subexpression 
53   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
 42  Simple common subexpression 
 43  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
54  44  When we see 
55   x1 = C a b 
56   x2 = C x1 b 
 45  x1 = C a b 
 46  x2 = C x1 b 
57  47  we build up a reverse mapping: C a b > x1 
58   C x1 b > x2 
 48  C x1 b > x2 
59  49  and apply that to the rest of the program. 
60  50  
61  51  When we then see 
62   y1 = C a b 
63   y2 = C y1 b 
 52  y1 = C a b 
 53  y2 = C y1 b 
64  54  we replace the C a b with x1. But then we *dont* want to 
65  55  add x1 > y1 to the mapping. Rather, we want the reverse, y1 > x1 
66  56  so that a subsequent binding 
67   y2 = C y1 b 
68   will get transformed to C x1 b, and then to x2. 
 57  y2 = C y1 b 
 58  will get transformed to C x1 b, and then to x2. 
69  59  
70  60  So we carry an extra var>var substitution which we apply *before* looking up in the 
71  61  reverse mapping. 
… 
… 
Note [Shadowing] 
75  65  ~~~~~~~~~~~~~~~~ 
76  66  We have to be careful about shadowing. 
77  67  For example, consider 
78   f = \x > let y = x+x in 
79   h = \x > x+x 
80   in ... 
 68  f = \x > let y = x+x in 
 69  h = \x > x+x 
 70  in ... 
81  71  
82  72  Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no 
83  73  shadowing, but it doesn't any more (it proved too hard), so we clone as we go. 
… 
… 
Note [Case binders 1] 
87  77  ~~~~~~~~~~~~~~~~~~~~~~ 
88  78  Consider 
89  79  
90   f = \x > case x of wild { 
91   (a:as) > case a of wild1 { 
92   (p,q) > ...(wild1:as)... 
 80  f = \x > case x of wild { 
 81  (a:as) > case a of wild1 { 
 82  (p,q) > ...(wild1:as)... 
93  83  
94  84  Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. 
95  85  But that's not quite obvious. In general we want to keep it as (wild1:as), 
… 
… 
to try to replaces uses of 'a' with uses of 'wild1' 
102  92  Note [Case binders 2] 
103  93  ~~~~~~~~~~~~~~~~~~~~~~ 
104  94  Consider 
105   case (h x) of y > ...(h x)... 
 95  case (h x) of y > ...(h x)... 
106  96  
107  97  We'd like to replace (h x) in the alternative, by y. But because of 
108  98  the preceding [Note: case binders 1], we only want to add the mapping 
109   scrutinee > case binder 
 99  scrutinee > case binder 
110  100  to the reverse CSE mapping if the scrutinee is a nontrivial expression. 
111  101  (If the scrutinee is a simple variable we want to add the mapping 
112   case binder > scrutinee 
 102  case binder > scrutinee 
113  103  to the substitution 
114  104  
115  105  Note [Unboxed tuple case binders] 
116  106  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
117  107  Consider 
118   case f x of t { (# a,b #) > 
119   case ... of 
120   True > f x 
121   False > 0 } 
 108  case f x of t { (# a,b #) > 
 109  case ... of 
 110  True > f x 
 111  False > 0 } 
122  112  
123  113  We must not replace (f x) by t, because t is an unboxedtuple binder. 
124  114  Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is 
125   f x > (# a,b #) 
 115  f x > (# a,b #) 
126  116  That is why the CSEMap has pairs of expressions. 
127  117  
128  118  Note [CSE for INLINE and NOINLINE] 
129  119  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
130  120  We are careful to do no CSE inside functions that the user has marked as 
131   INLINE or NOINLINE. In terms of Core, that means 
 121  INLINE or NOINLINE. In terms of Core, that means 
132  122  
133   a) we do not do CSE inside an InlineRule 
 123  a) we do not do CSE inside an InlineRule 
134  124  
135   b) we do not do CSE on the RHS of a binding b=e 
136   unless b's InlinePragma is AlwaysActive 
 125  b) we do not do CSE on the RHS of a binding b=e 
 126  unless b's InlinePragma is AlwaysActive 
137  127  
138  128  Here's why (examples from Roman Leshchinskiy). Consider 
139  129  
140   yes :: Int 
141   {# NOINLINE yes #} 
142   yes = undefined 
 130  yes :: Int 
 131  {# NOINLINE yes #} 
 132  yes = undefined 
143  133  
144   no :: Int 
145   {# NOINLINE no #} 
146   no = undefined 
 134  no :: Int 
 135  {# NOINLINE no #} 
 136  no = undefined 
147  137  
148   foo :: Int > Int > Int 
149   {# NOINLINE foo #} 
150   foo m n = n 
 138  foo :: Int > Int > Int 
 139  {# NOINLINE foo #} 
 140  foo m n = n 
151  141  
152   {# RULES "foo/no" foo no = id #} 
 142  {# RULES "foo/no" foo no = id #} 
153  143  
154   bar :: Int > Int 
155   bar = foo yes 
 144  bar :: Int > Int 
 145  bar = foo yes 
156  146  
157  147  We do not expect the rule to fire. But if we do CSE, then we get 
158  148  yes=no, and the rule does fire. Worse, whether we get yes=no or 
… 
… 
no=yes depends on the order of the definitions. 
161  151  In general, CSE should probably never touch things with INLINE pragmas 
162  152  as this could lead to surprising results. Consider 
163  153  
164   {# INLINE foo #} 
165   foo = <rhs> 
 154  {# INLINE foo #} 
 155  foo = <rhs> 
166  156  
167   {# NOINLINE bar #} 
168   bar = <rhs>  Same rhs as foo 
 157  {# NOINLINE bar #} 
 158  bar = <rhs>  Same rhs as foo 
169  159  
170  160  If CSE produces 
171   foo = bar 
 161  foo = bar 
172  162  then foo will never be inlined (when it should be); but if it produces 
173   bar = foo 
 163  bar = foo 
174  164  bar will be inlined (when it should not be). Even if we remove INLINE foo, 
175  165  we'd still like foo to be inlined if rhs is small. This won't happen 
176  166  with foo = bar. 
177  167  
178  168  Not CSEing inside INLINE also solves an annoying bug in CSE. Consider 
179  169  a worker/wrapper, in which the worker has turned into a single variable: 
180   $wf = h 
181   f = \x > ...$wf... 
 170  $wf = h 
 171  f = \x > ...$wf... 
182  172  Now CSE may transform to 
183   f = \x > ...h... 
 173  f = \x > ...h... 
184  174  But the WorkerInfo for f still says $wf, which is now dead! This won't 
185  175  happen now that we don't look inside INLINEs (which wrappers are). 
186  176  
187  177  
188  178  %************************************************************************ 
189   %* * 
 179  %* * 
190  180  \section{Common subexpression} 
191   %* * 
 181  %* * 
192  182  %************************************************************************ 
193  183  
194  184  \begin{code} 
… 
… 
cseProgram binds = cseBinds emptyCSEnv binds 
198  188  cseBinds :: CSEnv > [CoreBind] > [CoreBind] 
199  189  cseBinds _ [] = [] 
200  190  cseBinds env (b:bs) = (b':bs') 
201   where 
202   (env1, b') = cseBind env b 
203   bs' = cseBinds env1 bs 
 191  where 
 192  (env1, b') = cseBind env b 
 193  bs' = cseBinds env1 bs 
204  194  
205  195  cseBind :: CSEnv > CoreBind > (CSEnv, CoreBind) 
206   cseBind env (NonRec b e) 
 196  cseBind env (NonRec b e) 
207  197  = (env2, NonRec b' e') 
208  198  where 
209  199  (env1, b') = addBinder env b 
… 
… 
cseBind env (Rec pairs) 
219  209  cseRhs :: CSEnv > (OutBndr, InExpr) > (CSEnv, OutExpr) 
220  210  cseRhs env (id',rhs) 
221  211  = case lookupCSEnv env rhs' of 
222   Just other_expr > (env, other_expr) 
223   Nothing > (addCSEnvItem env rhs' (Var id'), rhs') 
 212  Just other_expr > (env, other_expr) 
 213  Nothing > (addCSEnvItem env rhs' (Var id'), rhs') 
224  214  where 
225  215  rhs'  isAlwaysActive (idInlineActivation id') = cseExpr env rhs 
226    otherwise = rhs 
227    See Note [CSE for INLINE and NOINLINE] 
 216   otherwise = rhs 
 217   See Note [CSE for INLINE and NOINLINE] 
228  218  
229  219  tryForCSE :: CSEnv > InExpr > OutExpr 
230  220  tryForCSE env expr 
231    exprIsTrivial expr' = expr'  No point 
 221   exprIsTrivial expr' = expr'  No point 
232  222   Just smaller < lookupCSEnv env expr' = smaller 
233  223   otherwise = expr' 
234  224  where 
… 
… 
cseExpr :: CSEnv > InExpr > OutExpr 
238  228  cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) 
239  229  cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) 
240  230  cseExpr _ (Lit lit) = Lit lit 
241   cseExpr env (Var v) = lookupSubst env v 
242   cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) 
243   cseExpr env (Tick t e) = Tick t (cseExpr env e) 
 231  cseExpr env (Var v) = lookupSubst env v 
 232  cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) 
 233  cseExpr env (Tick t e) = Tick t (cseExpr env e) 
244  234  cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) 
245   cseExpr env (Lam b e) = let (env', b') = addBinder env b 
246   in Lam b' (cseExpr env' e) 
247   cseExpr env (Let bind e) = let (env', bind') = cseBind env bind 
248   in Let bind' (cseExpr env' e) 
 235  cseExpr env (Lam b e) = let (env', b') = addBinder env b 
 236  in Lam b' (cseExpr env' e) 
 237  cseExpr env (Let bind e) = let (env', bind') = cseBind env bind 
 238  in Let bind' (cseExpr env' e) 
249  239  cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' 
250   where 
 240  where 
251  241  alts' = cseAlts env' scrut' bndr bndr'' alts 
252   scrut' = tryForCSE env scrut 
253   (env', bndr') = addBinder env bndr 
254   bndr'' = zapIdOccInfo bndr' 
255    The swizzling from Note [Case binders 2] may 
256    cause a dead case binder to be alive, so we 
257    play safe here and bring them all to life 
 242  scrut' = tryForCSE env scrut 
 243  (env', bndr') = addBinder env bndr 
 244  bndr'' = zapIdOccInfo bndr' 
 245   The swizzling from Note [Case binders 2] may 
 246   cause a dead case binder to be alive, so we 
 247   play safe here and bring them all to life 
258  248  
259  249  cseAlts :: CSEnv > OutExpr > InBndr > InBndr > [InAlt] > [OutAlt] 
260  250  
261  251  cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] 
262  252   isUnboxedTupleCon con 
263    Unboxed tuples are special because the case binder isn't 
264    a real value. See Note [Unboxed tuple case binders] 
 253   Unboxed tuples are special because the case binder isn't 
 254   a real value. See Note [Unboxed tuple case binders] 
265  255  = [(DataAlt con, args'', tryForCSE new_env rhs)] 
266  256  where 
267  257  (env', args') = addBinders env args 
268   args'' = map zapIdOccInfo args'  They should all be ids 
269    Same motivation for zapping as [Case binders 2] only this time 
270    it's Note [Unboxed tuple case binders] 
 258  args'' = map zapIdOccInfo args'  They should all be ids 
 259   Same motivation for zapping as [Case binders 2] only this time 
 260   it's Note [Unboxed tuple case binders] 
271  261  new_env  exprIsCheap scrut' = env' 
272    otherwise = extendCSEnv env' scrut' tup_value 
 262   otherwise = extendCSEnv env' scrut' tup_value 
273  263  tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr)) 
274  264  
275  265  cseAlts env scrut' bndr bndr' alts 
276  266  = map cse_alt alts 
277  267  where 
278  268  (con_target, alt_env) 
279   = case scrut' of 
280   Var v' > (v', extendCSSubst env bndr v')  See Note [Case binders 1] 
281    map: bndr > v' 
 269  = case scrut' of 
 270  Var v' > (v', extendCSSubst env bndr v')  See Note [Case binders 1] 
 271   map: bndr > v' 
282  272  
283   _ > (bndr', extendCSEnv env scrut' (Var bndr'))  See Note [Case binders 2] 
284    map: scrut' > bndr' 
 273  _ > (bndr', extendCSEnv env scrut' (Var bndr'))  See Note [Case binders 2] 
 274   map: scrut' > bndr' 
285  275  
286  276  arg_tys = tyConAppArgs (idType bndr) 
287  277  
288  278  cse_alt (DataAlt con, args, rhs) 
289    not (null args) 
290    Don't try CSE if there are no args; it just increases the number 
291    of live vars. E.g. 
292    case x of { True > ....True.... } 
293    Don't replace True by x! 
294    Hence the 'null args', which also deal with literals and DEFAULT 
295   = (DataAlt con, args', tryForCSE new_env rhs) 
296   where 
297   (env', args') = addBinders alt_env args 
298   new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) 
299   (Var con_target) 
 279   not (null args) 
 280   Don't try CSE if there are no args; it just increases the number 
 281   of live vars. E.g. 
 282   case x of { True > ....True.... } 
 283   Don't replace True by x! 
 284   Hence the 'null args', which also deal with literals and DEFAULT 
 285  = (DataAlt con, args', tryForCSE new_env rhs) 
 286  where 
 287  (env', args') = addBinders alt_env args 
 288  new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) 
 289  (Var con_target) 
300  290  
301  291  cse_alt (con, args, rhs) 
302   = (con, args', tryForCSE env' rhs) 
303   where 
304   (env', args') = addBinders alt_env args 
 292  = (con, args', tryForCSE env' rhs) 
 293  where 
 294  (env', args') = addBinders alt_env args 
305  295  \end{code} 
306  296  
307  297  
308  298  %************************************************************************ 
309   %* * 
 299  %* * 
310  300  \section{The CSE envt} 
311   %* * 
 301  %* * 
312  302  %************************************************************************ 
313  303  
314  304  \begin{code} 
315   type InExpr = CoreExpr  Precloning 
 305  type InExpr = CoreExpr  Precloning 
316  306  type InBndr = CoreBndr 
317  307  type InAlt = CoreAlt 
318  308  
319   type OutExpr = CoreExpr  Postcloning 
 309  type OutExpr = CoreExpr  Postcloning 
320  310  type OutBndr = CoreBndr 
321  311  type OutAlt = CoreAlt 
322  312  
… 
… 
type OutAlt = CoreAlt 
325  315  data CSEnv = CS { cs_map :: CSEMap 
326  316  , cs_subst :: Subst } 
327  317  
328   type CSEMap = UniqFM [(OutExpr, OutExpr)]  This is the reverse mapping 
329    It maps the hashcode of an expression e to list of (e,e') pairs 
330    This means that it's good to replace e by e' 
331    INVARIANT: The expr in the range has already been CSE'd 
 318  type CSEMap = UniqFM [(OutExpr, OutExpr)]  This is the reverse mapping 
 319   It maps the hashcode of an expression e to list of (e,e') pairs 
 320   This means that it's good to replace e by e' 
 321   INVARIANT: The expr in the range has already been CSE'd 
332  322  
333  323  emptyCSEnv :: CSEnv 
334  324  emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } 
… 
… 
emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } 
336  326  lookupCSEnv :: CSEnv > OutExpr > Maybe OutExpr 
337  327  lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr 
338  328  = case lookupUFM oldmap (hashExpr expr) of 
339   Nothing > Nothing 
340   Just pairs > lookup_list pairs 
 329  Nothing > Nothing 
 330  Just pairs > lookup_list pairs 
341  331  where 
342  332  in_scope = substInScope sub 
343  333  
344  334   In this lookup we use full expression equality 
345  335   Reason: when expressions differ we generally find out quickly 
346  336   but I found that cheapEqExpr was saying (\x.x) /= (\y.y), 
347    and this kind of thing happened in real programs 
 337   and this kind of thing happened in real programs 
348  338  lookup_list :: [(OutExpr,OutExpr)] > Maybe OutExpr 
349   lookup_list ((e,e'):es) 
 339  lookup_list ((e,e'):es) 
350  340   eqExpr in_scope e expr = Just e' 
351    otherwise = lookup_list es 
 341   otherwise = lookup_list es 
352  342  lookup_list [] = Nothing 
353  343  
354  344  addCSEnvItem :: CSEnv > OutExpr > OutExpr > CSEnv 
355  345  addCSEnvItem env expr expr'  exprIsBig expr = env 
356    otherwise = extendCSEnv env expr expr' 
 346   otherwise = extendCSEnv env expr expr' 
357  347   We don't try to CSE big expressions, because they are expensive to compare 
358  348   (and are unlikely to be the same anyway) 
359  349  
… 
… 
extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' 
362  352  = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] } 
363  353  where 
364  354  hash = hashExpr expr 
365   combine old new 
366   = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result 
367   where 
368   result = new ++ old 
369   short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result) 
370   long_msg  opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
371    otherwise = empty 
 355  combine old new 
 356  = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result 
 357  where 
 358  result = new ++ old 
 359  short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result) 
 360  long_msg  opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
 361   otherwise = empty 
372  362  
373  363  #else 
374  364   NEW  
… 
… 
emptyCSEnv :: CSEnv 
380  370  emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } 
381  371  
382  372  lookupCSEnv :: CSEnv > OutExpr > Maybe OutExpr 
383   lookupCSEnv (CS { cs_map = csmap }) expr 
 373  lookupCSEnv (CS { cs_map = csmap }) expr 
384  374  = case lookupCoreMap csmap expr of 
385  375  Just (_,e) > Just e 
386  376  Nothing > Nothing 
… 
… 
extendCSSubst :: CSEnv > Id > Id > CSEnv 
408  398  extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } 
409  399  
410  400  addBinder :: CSEnv > Var > (CSEnv, Var) 
411   addBinder cse v = (cse { cs_subst = sub' }, v') 
 401  addBinder cse v = (cse { cs_subst = sub' }, v') 
412  402  where 
413  403  (sub', v') = substBndr (cs_subst cse) v 
414  404  
415  405  addBinders :: CSEnv > [Var] > (CSEnv, [Var]) 
416   addBinders cse vs = (cse { cs_subst = sub' }, vs') 
 406  addBinders cse vs = (cse { cs_subst = sub' }, vs') 
417  407  where 
418  408  (sub', vs') = substBndrs (cs_subst cse) vs 
419  409  
420  410  addRecBinders :: CSEnv > [Id] > (CSEnv, [Id]) 
421   addRecBinders cse vs = (cse { cs_subst = sub' }, vs') 
 411  addRecBinders cse vs = (cse { cs_subst = sub' }, vs') 
422  412  where 
423  413  (sub', vs') = substRecBndrs (cs_subst cse) vs 
424  414  \end{code} 