SimplCore.lhs 23.9 KB
Newer Older
1
2
3
4
5
6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SimplCore]{Driver for simplifying @Core@ programs}

\begin{code}
7
module SimplCore ( core2core, simplifyExpr ) where
8
9
10

#include "HsVersions.h"

11
import DynFlags		( CoreToDo(..), SimplifierSwitch(..),
chak's avatar
chak committed
12
			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
13
			  getCoreToDo )
14
import CoreSyn
15
import HscTypes		( HscEnv(..), ModGuts(..), ExternalPackageState(..),
16
			  Dependencies( dep_mods ), 
17
			  hscEPS, hptRules )
18
import CSE		( cseProgram )
19
20
import Rules		( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
			  extendRuleBaseList, pprRuleBase, ruleCheckProgram,
21
			  addSpecInfo, addIdSpecialisations )
22
import PprCore		( pprCoreBindings, pprCoreExpr, pprRules )
23
import OccurAnal	( occurAnalysePgm, occurAnalyseExpr )
24
25
import IdInfo		( setNewStrictnessInfo, newStrictnessInfo, 
			  setWorkerInfo, workerInfo,
26
			  setInlinePragInfo, inlinePragInfo,
27
			  setSpecInfo, specInfo, specInfoRules )
28
import CoreUtils	( coreBindsSize )
29
import Simplify		( simplTopBinds, simplExpr )
30
import SimplEnv		( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
31
import SimplMonad
32
33
import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint		( endPass )
34
35
import FloatIn		( floatInwards )
import FloatOut		( floatOutwards )
36
import Id		( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
37
			  idSpecialisation, idName )
38
import VarSet
39
import VarEnv
40
import NameEnv		( lookupNameEnv )
41
42
43
import LiberateCase	( liberateCase )
import SAT		( doStaticArgs )
import Specialise	( specProgram)
44
import SpecConstr	( specConstrProgram)
45
import DmdAnal		( dmdAnalPgm )
46
import WorkWrap	        ( wwTopBinds )
47
48
#ifdef OLD_STRICTNESS
import StrictAnal	( saBinds )
49
import CprAnalyse       ( cprAnalyse )
50
#endif
51

52
import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
53
54
import IO		( hPutStr, stderr )
import Outputable
55
import List		( partition )
56
import Maybes		( orElse )
57
58
59
60
61
62
63
64
65
\end{code}

%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
66
67
68
core2core :: HscEnv
	  -> ModGuts
	  -> IO ModGuts
69

70
core2core hsc_env guts
71
  = do
72
        let dflags = hsc_dflags hsc_env
73
	    core_todos = getCoreToDo dflags
74

75
	us <- mkSplitUniqSupply 's'
76
	let (cp_us, ru_us) = splitUniqSupply us
77

78
		-- COMPUTE THE RULE BASE TO USE
79
	(imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
80

81
		-- DO THE BUSINESS
82
	(stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
83
			 		(zeroSimplCount dflags) 
84
					guts' core_todos
85

86
	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
87
88
89
		  "Grand total simplifier statistics"
		  (pprSimplCount stats)

90
	return guts''
91
92


93
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
94
95
	     -> CoreExpr
	     -> IO CoreExpr
96
97
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
98
simplifyExpr dflags expr
99
  = do	{
100
101
	; showPass dflags "Simplify"

102
103
	; us <-  mkSplitUniqSupply 's'

104
105
	; let (expr', _counts) = initSmpl dflags us $
				 simplExprGently gentleSimplEnv expr
106

107
	; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
108
109
110
111
112
			(pprCoreExpr expr')

	; return expr'
	}

113
114
gentleSimplEnv :: SimplEnv
gentleSimplEnv = mkSimplEnv SimplGently 
115
116
			    (isAmongSimpl [])
			    emptyRuleBase
117

118
doCorePasses :: HscEnv
119
             -> RuleBase        -- the imported main rule base
120
             -> UniqSupply      -- uniques
121
122
	     -> SimplCount      -- simplifier stats
             -> ModGuts	        -- local binds in (with rules attached)
123
             -> [CoreToDo]      -- which passes to do
124
             -> IO (SimplCount, ModGuts)
125

126
doCorePasses hsc_env rb us stats guts []
127
  = return (stats, guts)
128

129
130
131
doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) 
  = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2) 

132
doCorePasses hsc_env rb us stats guts (to_do : to_dos) 
133
  = do
134
	let (us1, us2) = splitUniqSupply us
135
136
	(stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
	doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
137

138
139
doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
	   -> ModGuts -> IO (SimplCount, ModGuts)
140
141
doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
doCorePass CoreCSE		       = _scc_ "CommonSubExpr" trBinds  cseProgram
142
doCorePass CoreLiberateCase	       = _scc_ "LiberateCase"  liberateCase
143
144
145
146
147
148
149
150
151
152
153
154
155
doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
doCorePass CoreDoStaticArgs	       = _scc_ "StaticArgs"    trBinds  doStaticArgs
doCorePass CoreDoStrictness	       = _scc_ "Stranal"       trBinds  dmdAnalPgm
doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
doCorePass CoreDoSpecConstr	       = _scc_ "SpecConstr"    trBindsU specConstrProgram
doCorePass CoreDoGlomBinds	       = trBinds glomBinds
doCorePass CoreDoPrintCore	       = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
#ifdef OLD_STRICTNESS		       
doCorePass CoreDoOldStrictness	       = _scc_ "OldStrictness" trBinds doOldStrictness
156
157
#else
doCorePass CoreDoOldStrictness	       = panic "CoreDoOldStrictness"
158
#endif
159
doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
160

161
#ifdef OLD_STRICTNESS
162
doOldStrictness dfs binds
163
164
165
  = do binds1 <- saBinds dfs binds
       binds2 <- cprAnalyse dfs binds1
       return binds2
166
167
#endif

168
printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
169

170
ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
171
				      printDump (ruleCheckProgram phase pat binds)
172

173
174
175
-- Most passes return no stats and don't change rules
trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
176
	-> IO (SimplCount, ModGuts)
177
178
trBinds do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags (mg_binds guts)
179
	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
180
181
182
183
184
  where
    dflags = hsc_dflags hsc_env

trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
185
	-> IO (SimplCount, ModGuts)
186
187
trBindsU do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags us (mg_binds guts)
188
	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
189
190
191
192
193
194
  where
    dflags = hsc_dflags hsc_env

-- Observer passes just peek; don't modify the bindings at all
observe :: (DynFlags -> [CoreBind] -> IO a)
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
195
	-> IO (SimplCount, ModGuts)
196
197
observe do_pass hsc_env us rb guts 
  = do	{ binds <- do_pass dflags (mg_binds guts)
198
	; return (zeroSimplCount dflags, guts) }
199
200
  where
    dflags = hsc_dflags hsc_env
201
202
203
\end{code}


204

205
206
207
208
209
210
%************************************************************************
%*									*
\subsection{Dealing with rules}
%*									*
%************************************************************************

211
212
-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
-- It attaches those rules that are for local Ids to their binders, and
213
-- returns the remainder attached to Ids in an IdSet.  
214
215

\begin{code}
216
prepareRules :: HscEnv 
217
	     -> ModGuts
218
	     -> UniqSupply
219
220
	     -> IO (RuleBase, 		-- Rule base for imported things, incl
					-- (a) rules defined in this module (orphans)
221
222
223
					-- (b) rules from other modules in home package
					-- but not things from other packages

224
225
226
		    ModGuts)		-- Modified fields are 
					--	(a) Bindings have rules attached,
					-- 	(b) Rules are now just orphan rules
227

228
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
229
	     guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
230
	     us 
231
  = do	{ let 	-- Simplify the local rules; boringly, we need to make an in-scope set
232
233
		-- from the local binders, to avoid warnings from Simplify.simplVar
	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
234
	      env	       = setInScopeSet gentleSimplEnv local_ids 
235
	      (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
236
	      home_pkg_rules   = hptRules hsc_env (dep_mods deps)
237

238
239
		-- Find the rules for locally-defined Ids; then we can attach them
		-- to the binders in the top-level bindings
240
241
242
243
244
245
246
247
248
249
250
251
252
		-- 
		-- Reason
		-- 	- It makes the rules easier to look up
		--	- It means that transformation rules and specialisations for
		--	  locally defined Ids are handled uniformly
		--	- It keeps alive things that are referred to only from a rule
		--	  (the occurrence analyser knows about rules attached to Ids)
		--	- It makes sure that, when we apply a rule, the free vars
		--	  of the RHS are more likely to be in scope
		--	- The imported rules are carried in the in-scope set
		--	  which is extended on each iteration by the new wave of
		--	  local binders; any rules which aren't on the binding will
		--	  thereby get dropped
253
	      (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
254
255
	      local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
	      binds_w_rules   = updateBinders local_rule_base binds
256

257
258
259
	      hpt_rule_base = mkRuleBase home_pkg_rules
	      imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps

260
	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
261
		(vcat [text "Local rules", pprRules better_rules,
262
		       text "",
263
		       text "Imported rules", pprRuleBase imp_rule_base])
264

265
266
	; return (imp_rule_base, guts { mg_binds = binds_w_rules, 
					mg_rules = rules_for_imps })
267
    }
268

269
updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
270
updateBinders local_rules binds
271
  = map update_bndrs binds
272
  where
273
274
275
    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]

276
277
    update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
			  Nothing    -> bndr
278
279
280
			  Just rules -> bndr `addIdSpecialisations` rules
				-- The binder might have some existing rules,
				-- arising from specialisation pragmas
281
282
\end{code}

283

284
285
286
287
288
We must do some gentle simplification on the template (but not the RHS)
of each rule.  The case that forced me to add this was the fold/build rule,
which without simplification looked like:
	fold k z (build (/\a. g a))  ==>  ...
This doesn't match unless you do eta reduction on the build argument.
289

290
\begin{code}
291
simplRule env rule@(BuiltinRule {})
292
  = returnSmpl rule
293
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
294
295
296
  = simplBinders env bndrs		`thenSmpl` \ (env, bndrs') -> 
    mapSmpl (simplExprGently env) args	`thenSmpl` \ args' ->
    simplExprGently env rhs		`thenSmpl` \ rhs' ->
297
    returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
298

299
300
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
301
--	augment g (build h) 
302
-- we do not want to get
303
--	augment (\a. g a) (build h)
304
-- otherwise we don't match when given an argument like
305
--	(\a. h a a)
306
307
308
309
310
311
--
-- The simplifier does indeed do eta reduction (it's in
-- Simplify.completeLam) but only if -O is on.
\end{code}

\begin{code}
312
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
313
314
315
316
317
318
-- Simplifies an expression 
-- 	does occurrence analysis, then simplification
--	and repeats (twice currently) because one pass
--	alone leaves tons of crud.
-- Used (a) for user expressions typed in at the interactive prompt
--	(b) the LHS and RHS of a RULE
319
320
321
322
323
--
-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice

324
simplExprGently env expr
325
326
  = simplExpr env (occurAnalyseExpr expr) 	`thenSmpl` \ expr1 ->
    simplExpr env (occurAnalyseExpr expr1)
327
328
\end{code}

329
330
331
332
333
334
335

%************************************************************************
%*									*
\subsection{Glomming}
%*									*
%************************************************************************

336
\begin{code}
337
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
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
-- Glom all binds together in one Rec, in case any
-- transformations have introduced any new dependencies
--
-- NB: the global invariant is this:
--	*** the top level bindings are never cloned, and are always unique ***
--
-- We sort them into dependency order, but applying transformation rules may
-- make something at the top refer to something at the bottom:
--	f = \x -> p (q x)
--	h = \y -> 3
--	
--	RULE:  p (q x) = h x
--
-- Applying this rule makes f refer to h, 
-- although it doesn't appear to in the source program.  
-- This pass lets us control where it happens.
--
-- NOTICE that this cannot happen for rules whose head is a locally-defined
-- function.  It only happens for rules whose head is an imported function
-- (p in the example above).  So, for example, the rule had been
--	RULE: f (p x) = h x
-- then the rule for f would be attached to f itself (in its IdInfo) 
-- by prepareLocalRuleBase and h would be regarded by the occurrency 
-- analyser as free in f.

363
glomBinds dflags binds
364
  = do { showPass dflags "GlomBinds" ;
365
366
367
368
369
370
	 let { recd_binds = [Rec (flattenBinds binds)] } ;
	 return recd_binds }
	-- Not much point in printing the result... 
	-- just consumes output bandwidth
\end{code}

371

372
373
374
375
376
377
378
%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
379
simplifyPgm :: SimplifierMode
380
	    -> [SimplifierSwitch]
381
	    -> HscEnv
382
	    -> UniqSupply
383
384
	    -> RuleBase
	    -> ModGuts
385
	    -> IO (SimplCount, ModGuts)  -- New bindings
386

387
simplifyPgm mode switches hsc_env us imp_rule_base guts
388
  = do {
389
	showPass dflags "Simplify";
390

391
392
	(termination_msg, it_count, counts_out, binds') 
	   <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
393

394
395
	dumpIfSet (dopt Opt_D_verbose_core2core dflags 
                   && dopt Opt_D_dump_simpl_stats dflags)
396
397
398
399
400
		  "Simplifier statistics"
		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
			 text "",
			 pprSimplCount counts_out]);

401
	endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
402

403
	return (counts_out, guts { mg_binds = binds' })
404
405
    }
  where
406
407
408
409
410
411
412
    dflags 	   = hsc_dflags hsc_env
    phase_info	   = case mode of
		   	  SimplGently  -> "gentle"
		   	  SimplPhase n -> show n
		   
    sw_chkr	   = isAmongSimpl switches
    max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
413
 
414
    do_iteration us iteration_no counts binds
415
416
417
418
419
420
421
422
423
424
425
426
427
428
	-- iteration_no is the number of the iteration we are
	-- about to begin, with '1' for the first
      | iteration_no > max_iterations	-- Stop if we've run out of iterations
      = do {
#ifdef DEBUG
	    if  max_iterations > 2 then
		hPutStr stderr ("NOTE: Simplifier still going after " ++ 
				show max_iterations ++ 
			    	" iterations; bailing out.\n")
	    else 
		return ();
#endif
		-- Subtract 1 from iteration_no to get the
		-- number of iterations we actually completed
429
	    return ("Simplifier baled out", iteration_no - 1, counts, binds)
430
431
	}

432
433
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
434
      | let sz = coreBindsSize binds in sz == sz
435
436
      = do {
		-- Occurrence analysis
437
	   let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
438
	   dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
439
440
		     (pprCoreBindings tagged_binds);

441
442
443
444
445
	   	-- Get any new rules, and extend the rule base
		-- We need to do this regularly, because simplification can
		-- poke on IdInfo thunks, which in turn brings in new rules
		-- behind the scenes.  Otherwise there's a danger we'll simply
		-- miss the rules for Ids hidden inside imported inlinings
446
447
	   eps <- hscEPS hsc_env ;
	   let	{ rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
448
		; simpl_env  = mkSimplEnv mode sw_chkr rule_base' } ;
449
450
	   
		-- Simplify the program
451
452
453
454
455
456
457
		-- We do this with a *case* not a *let* because lazy pattern
		-- matching bit us with bad space leak!
		-- With a let, we ended up with
		--   let
		--	t = initSmpl ...
		--	counts' = snd t
		--   in
458
		-- 	case t of {(_,counts') -> if counts'=0 then ... }
459
460
		-- So the conditional didn't force counts', because the
		-- selection got duplicated.  Sigh!
461
	   case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
462
	  	(binds', counts') -> do {
463

464
	   let	{ all_counts = counts `plusSimplCount` counts'
465
		; herald     = "Simplifier phase " ++ phase_info ++ 
466
467
468
			      ", iteration " ++ show iteration_no ++
			      " out of " ++ show max_iterations
	        } ;
469
470
471

		-- Stop if nothing happened; don't dump output
	   if isZeroSimplCount counts' then
472
		return ("Simplifier reached fixed point", iteration_no, 
473
			all_counts, binds')
474
	   else do {
475
476
477
478
479
		-- Short out indirections
		-- We do this *after* at least one run of the simplifier 
		-- because indirection-shorting uses the export flag on *occurrences*
		-- and that isn't guaranteed to be ok until after the first run propagates
		-- stuff from the binding site to its occurrences
480
481
482
		--
		-- ToDo: alas, this means that indirection-shorting does not happen at all
		--	 if the simplifier does nothing (not common, I know, but unsavoury)
483
	   let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
484
485

		-- Dump the result of this iteration
486
	   dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
487
		         (pprSimplCount counts') ;
488
	   endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
489

490
		-- Loop
491
  	   do_iteration us2 (iteration_no + 1) all_counts binds''
492
	}  } } }
493
494
495
      where
  	  (us1, us2) = splitUniqSupply us
\end{code}
496
497
498
499


%************************************************************************
%*									*
500
		Shorting out indirections
501
502
503
%*									*
%************************************************************************

504
If we have this:
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614

	x_local = <expression>
	...bindings...
	x_exported = x_local

where x_exported is exported, and x_local is not, then we replace it with this:

	x_exported = <expression>
	x_local = x_exported
	...bindings...

Without this we never get rid of the x_exported = x_local thing.  This
save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
makes strictness information propagate better.  This used to happen in
the final phase, but it's tidier to do it here.

STRICTNESS: if we have done strictness analysis, we want the strictness info on
x_local to transfer to x_exported.  Hence the copyIdInfo call.

RULES: we want to *add* any RULES for x_local to x_exported.

Note [Rules and indirection-zapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Problem: what if x_exported has a RULE that mentions something in ...bindings...?
Then the things mentioned can be out of scope!  Solution
 a) Make sure that in this pass the usage-info from x_exported is 
	available for ...bindings...
 b) If there are any such RULES, rec-ify the entire top-level. 
    It'll get sorted out next time round

Messing up the rules
~~~~~~~~~~~~~~~~~~~~
The example that went bad on me at one stage was this one:
	
    iterate :: (a -> a) -> a -> [a]
	[Exported]
    iterate = iterateList	
    
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterateList f x =  x : iterateList f (f x)
    	[Not exported]
    
    {-# RULES
    "iterate"	forall f x.	iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB" 		iterateFB (:) = iterateList
     #-}

This got shorted out to:

    iterateList :: (a -> a) -> a -> [a]
    iterateList = iterate
    
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterate f x =  x : iterate f (f x)
    
    {-# RULES
    "iterate"	forall f x.	iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB" 		iterateFB (:) = iterate
     #-}

And now we get an infinite loop in the rule system 
	iterate f x -> build (\cn -> iterateFB c f x)
		    -> iterateFB (:) f x
		    -> iterate f x

Tiresome old solution: 
	don't do shorting out if f has rewrite rules (see shortableIdInfo)

New solution (I think): 
	use rule switching-off pragmas to get rid 
	of iterateList in the first place


Other remarks
~~~~~~~~~~~~~
If more than one exported thing is equal to a local thing (i.e., the
local thing really is shared), then we do one only:
\begin{verbatim}
	x_local = ....
	x_exported1 = x_local
	x_exported2 = x_local
==>
	x_exported1 = ....

	x_exported2 = x_exported1
\end{verbatim}

We rely on prior eta reduction to simplify things like
\begin{verbatim}
	x_exported = /\ tyvars -> x_local tyvars
==>
	x_exported = x_local
\end{verbatim}
Hence,there's a possibility of leaving unchanged something like this:
\begin{verbatim}
	x_local = ....
	x_exported1 = x_local Int
\end{verbatim}
By the time we've thrown away the types in STG land this 
could be eliminated.  But I don't think it's very common
and it's dangerous to do this fiddling in STG land 
because we might elminate a binding that's mentioned in the
unfolding for something.

\begin{code}
type IndEnv = IdEnv Id		-- Maps local_id -> exported_id

shortOutIndirections :: [CoreBind] -> [CoreBind]
shortOutIndirections binds
  | isEmptyVarEnv ind_env = binds
615
616
  | no_need_to_flatten	  = binds'			-- See Note [Rules and indirect-zapping]
  | otherwise 		  = [Rec (flattenBinds binds')]	-- for this no_need_to_flatten stuff
617
618
  where
    ind_env 	       = makeIndEnv binds
619
620
    exp_ids 	       = varSetElems ind_env	-- These exported Ids are the subjects
    exp_id_set	       = mkVarSet exp_ids	-- of the indirection-elimination
621
    no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
    binds' 	       = concatMap zap binds

    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
    zap (Rec pairs)	  = [Rec (concatMap zapPair pairs)]

    zapPair (bndr, rhs)
	| bndr `elemVarSet` exp_id_set 		   = []
	| Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
						      (bndr, Var exp_id)]
	| otherwise				   = [(bndr,rhs)]
			     
makeIndEnv :: [CoreBind] -> IndEnv
makeIndEnv binds
  = foldr add_bind emptyVarEnv binds
  where
    add_bind :: CoreBind -> IndEnv -> IndEnv
    add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
    add_bind (Rec pairs)	      env = foldr add_pair env pairs

    add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
    add_pair (exported_id, Var local_id) env
	| shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
    add_pair (exported_id, rhs) env
	= env
			
shortMeOut ind_env exported_id local_id
-- The if-then-else stuff is just so I can get a pprTrace to see
-- how often I don't get shorting out becuase of IdInfo stuff
  = if isExportedId exported_id &&		-- Only if this is exported

       isLocalId local_id &&			-- Only if this one is defined in this
						-- 	module, so that we *can* change its
				 	 	-- 	binding to be the exported thing!

       not (isExportedId local_id) &&		-- Only if this one is not itself exported,
					   	--	since the transformation will nuke it
   
       not (local_id `elemVarEnv` ind_env)	-- Only if not already substituted for
    then
	True

{- No longer needed
664
	if isEmptySpecInfo (specInfo (idInfo exported_id)) 	-- Only if no rules
665
666
667
668
669
670
671
672
673
674
675
676
677
	then True	-- See note on "Messing up rules"
	else 
#ifdef DEBUG 
          pprTrace "shortMeOut:" (ppr exported_id)
#endif
                                                False
-}
    else
	False


-----------------
transferIdInfo :: Id -> Id -> Id
678
679
680
681
682
683
-- If we have
--	lcl_id = e; exp_id = lcl_id
-- and lcl_id has useful IdInfo, we don't want to discard it by going
--	gbl_id = e; lcl_id = gbl_id
-- Instead, transfer IdInfo from lcl_id to exp_id
-- Overwriting, rather than merging, seems to work ok.
684
685
686
687
688
689
transferIdInfo exported_id local_id
  = modifyIdInfo transfer exported_id
  where
    local_info = idInfo local_id
    transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
				 `setWorkerInfo`        workerInfo local_info
690
				 `setInlinePragInfo`	inlinePragInfo local_info
691
692
				 `setSpecInfo`	        addSpecInfo (specInfo exp_info)
							            (specInfo local_info)
693
\end{code}