SimplCore.lhs 24.2 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 FamInstEnv
37
import Id		( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
38
			  idSpecialisation, idName )
39
import VarSet
40
import VarEnv
41
import NameEnv		( lookupNameEnv )
42
43
44
import LiberateCase	( liberateCase )
import SAT		( doStaticArgs )
import Specialise	( specProgram)
45
import SpecConstr	( specConstrProgram)
46
import DmdAnal		( dmdAnalPgm )
47
import WorkWrap	        ( wwTopBinds )
48
49
#ifdef OLD_STRICTNESS
import StrictAnal	( saBinds )
50
import CprAnalyse       ( cprAnalyse )
51
#endif
52
import Vectorise        ( vectorise )
53

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

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

\begin{code}
68
69
70
core2core :: HscEnv
	  -> ModGuts
	  -> IO ModGuts
71

72
core2core hsc_env guts
73
  = do
74
        let dflags = hsc_dflags hsc_env
75
	    core_todos = getCoreToDo dflags
76

77
	us <- mkSplitUniqSupply 's'
78
	let (cp_us, ru_us) = splitUniqSupply us
79

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

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

88
	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
89
90
91
		  "Grand total simplifier statistics"
		  (pprSimplCount stats)

92
	return guts''
93
94


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

104
105
	; us <-  mkSplitUniqSupply 's'

106
	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
107
				 simplExprGently gentleSimplEnv expr
108

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

	; return expr'
	}

115
gentleSimplEnv :: SimplEnv
116
gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
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
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
151
doCorePass CoreDoVectorisation         = _scc_ "Vectorise"     vectorise
152
153
154
155
156
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
157
158
#else
doCorePass CoreDoOldStrictness	       = panic "CoreDoOldStrictness"
159
#endif
160
doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
161

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

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

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

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

trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
186
	-> IO (SimplCount, ModGuts)
187
188
trBindsU do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags us (mg_binds guts)
189
	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
190
191
192
193
194
195
  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
196
	-> IO (SimplCount, ModGuts)
197
198
observe do_pass hsc_env us rb guts 
  = do	{ binds <- do_pass dflags (mg_binds guts)
199
	; return (zeroSimplCount dflags, guts) }
200
201
  where
    dflags = hsc_dflags hsc_env
202
203
204
\end{code}


205

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

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

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

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

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

240
241
		-- Find the rules for locally-defined Ids; then we can attach them
		-- to the binders in the top-level bindings
242
243
244
245
246
247
248
249
250
251
252
253
254
		-- 
		-- 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
255
	      (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
256
257
	      local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
	      binds_w_rules   = updateBinders local_rule_base binds
258

259
260
261
	      hpt_rule_base = mkRuleBase home_pkg_rules
	      imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps

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

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

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

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

285

286
287
288
289
290
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.
291

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

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

\begin{code}
314
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
315
316
317
318
319
320
-- 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
321
322
323
324
325
--
-- 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

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

331
332
333
334
335
336
337

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

338
\begin{code}
339
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
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
-- 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.

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

373

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

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

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

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

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

403
	endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
404

405
	return (counts_out, guts { mg_binds = binds' })
406
407
    }
  where
408
409
410
411
412
413
414
    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
415
 
416
    do_iteration us iteration_no counts binds
417
418
419
420
421
422
423
424
425
426
427
428
429
430
	-- 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
431
	    return ("Simplifier baled out", iteration_no - 1, counts, binds)
432
433
	}

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

443
444
445
446
447
	   	-- 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
448
449
	   eps <- hscEPS hsc_env ;
	   let	{ rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
450
451
452
453
		; simpl_env  = mkSimplEnv mode sw_chkr 
		; simpl_binds = _scc_ "SimplTopBinds" 
				simplTopBinds simpl_env tagged_binds
		; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
454
455
	   
		-- Simplify the program
456
457
458
459
460
461
462
		-- 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
463
		-- 	case t of {(_,counts') -> if counts'=0 then ... }
464
465
		-- So the conditional didn't force counts', because the
		-- selection got duplicated.  Sigh!
466
	   case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
467
	  	(binds', counts') -> do {
468

469
	   let	{ all_counts = counts `plusSimplCount` counts'
470
		; herald     = "Simplifier phase " ++ phase_info ++ 
471
472
473
			      ", iteration " ++ show iteration_no ++
			      " out of " ++ show max_iterations
	        } ;
474
475
476

		-- Stop if nothing happened; don't dump output
	   if isZeroSimplCount counts' then
477
		return ("Simplifier reached fixed point", iteration_no, 
478
			all_counts, binds')
479
	   else do {
480
481
482
483
484
		-- 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
485
486
487
		--
		-- ToDo: alas, this means that indirection-shorting does not happen at all
		--	 if the simplifier does nothing (not common, I know, but unsavoury)
488
	   let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
489
490

		-- Dump the result of this iteration
491
	   dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
492
		         (pprSimplCount counts') ;
493
	   endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
494

495
		-- Loop
496
  	   do_iteration us2 (iteration_no + 1) all_counts binds''
497
	}  } } }
498
499
500
      where
  	  (us1, us2) = splitUniqSupply us
\end{code}
501
502
503
504


%************************************************************************
%*									*
505
		Shorting out indirections
506
507
508
%*									*
%************************************************************************

509
If we have this:
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
615
616
617
618
619

	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
620
621
  | no_need_to_flatten	  = binds'			-- See Note [Rules and indirect-zapping]
  | otherwise 		  = [Rec (flattenBinds binds')]	-- for this no_need_to_flatten stuff
622
623
  where
    ind_env 	       = makeIndEnv binds
624
625
    exp_ids 	       = varSetElems ind_env	-- These exported Ids are the subjects
    exp_id_set	       = mkVarSet exp_ids	-- of the indirection-elimination
626
    no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
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
664
665
666
667
668
    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
669
	if isEmptySpecInfo (specInfo (idInfo exported_id)) 	-- Only if no rules
670
671
672
673
674
675
676
677
678
679
680
681
682
	then True	-- See note on "Messing up rules"
	else 
#ifdef DEBUG 
          pprTrace "shortMeOut:" (ppr exported_id)
#endif
                                                False
-}
    else
	False


-----------------
transferIdInfo :: Id -> Id -> Id
683
684
685
686
687
688
-- 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.
689
690
691
692
693
694
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
695
				 `setInlinePragInfo`	inlinePragInfo local_info
696
697
				 `setSpecInfo`	        addSpecInfo (specInfo exp_info)
							            (specInfo local_info)
698
\end{code}