SimplCore.lhs 27.3 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
{-# OPTIONS -w #-}
8 9 10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 13
-- for details

14
module SimplCore ( core2core, simplifyExpr ) where
15 16 17

#include "HsVersions.h"

18
import DynFlags		( CoreToDo(..), SimplifierSwitch(..),
chak's avatar
chak committed
19
			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
20
			  getCoreToDo, shouldDumpSimplPhase )
21
import CoreSyn
22
import HscTypes
23
import CSE		( cseProgram )
24 25
import Rules		( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
			  extendRuleBaseList, pprRuleBase, ruleCheckProgram,
26
			  addSpecInfo, addIdSpecialisations )
27
import PprCore		( pprCoreBindings, pprCoreExpr, pprRules )
28
import OccurAnal	( occurAnalysePgm, occurAnalyseExpr )
29
import IdInfo		( setNewStrictnessInfo, newStrictnessInfo, 
30
			  setWorkerInfo, workerInfo, setSpecInfoHead,
31
			  setInlinePragInfo, inlinePragInfo,
32
			  setSpecInfo, specInfo, specInfoRules )
33
import CoreUtils	( coreBindsSize )
34
import Simplify		( simplTopBinds, simplExpr )
35
import SimplEnv		( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
36
import SimplMonad
37
import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
38
import CoreLint		( endPassIf, endIteration )
39 40
import FloatIn		( floatInwards )
import FloatOut		( floatOutwards )
41
import FamInstEnv
42 43 44 45
import Id
import DataCon
import TyCon		( tyConSelIds, tyConDataCons )
import Class		( classSelIds )
46
import VarSet
47
import VarEnv
48
import NameEnv		( lookupNameEnv )
49 50 51
import LiberateCase	( liberateCase )
import SAT		( doStaticArgs )
import Specialise	( specProgram)
52
import SpecConstr	( specConstrProgram)
53
import DmdAnal		( dmdAnalPgm )
54
import WorkWrap	        ( wwTopBinds )
55 56
#ifdef OLD_STRICTNESS
import StrictAnal	( saBinds )
57
import CprAnalyse       ( cprAnalyse )
58
#endif
59
import Vectorise        ( vectorise )
Ian Lynagh's avatar
Ian Lynagh committed
60
import Util
61

62
import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
63 64
import IO		( hPutStr, stderr )
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
65
import Control.Monad
66
import List		( partition, intersperse )
67
import Maybes
68 69 70 71 72 73 74 75 76
\end{code}

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

\begin{code}
77 78 79
core2core :: HscEnv
	  -> ModGuts
	  -> IO ModGuts
80

81
core2core hsc_env guts
82 83 84
  = do	{
	; let dflags = hsc_dflags hsc_env
	      core_todos = getCoreToDo dflags
85

86 87
	; us <- mkSplitUniqSupply 's'
	; let (cp_us, ru_us) = splitUniqSupply us
88

89
		-- COMPUTE THE RULE BASE TO USE
90 91 92 93 94
	; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us

		-- Note [Injecting implicit bindings]
        ; let implicit_binds = getImplicitBinds (mg_types guts1)
	      guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
95

96
		-- DO THE BUSINESS
97 98 99
	; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
			 		 (zeroSimplCount dflags) 
				 	 guts2 core_todos
100

101
	; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
102 103 104
		  "Grand total simplifier statistics"
		  (pprSimplCount stats)

105
	; return guts3 }
106 107


108
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
109 110
	     -> CoreExpr
	     -> IO CoreExpr
111 112
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
113
simplifyExpr dflags expr
114
  = do	{
115 116
	; showPass dflags "Simplify"

117 118
	; us <-  mkSplitUniqSupply 's'

119
	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
120
				 simplExprGently gentleSimplEnv expr
121

122
	; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
123 124 125 126 127
			(pprCoreExpr expr')

	; return expr'
	}

128
gentleSimplEnv :: SimplEnv
129
gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
130

131
doCorePasses :: HscEnv
132
             -> RuleBase        -- the imported main rule base
133
             -> UniqSupply      -- uniques
134 135
	     -> SimplCount      -- simplifier stats
             -> ModGuts	        -- local binds in (with rules attached)
136
             -> [CoreToDo]      -- which passes to do
137
             -> IO (SimplCount, ModGuts)
138

139
doCorePasses hsc_env rb us stats guts []
140
  = return (stats, guts)
141

142 143 144
doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) 
  = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2) 

145
doCorePasses hsc_env rb us stats guts (to_do : to_dos) 
146
  = do
147
	let (us1, us2) = splitUniqSupply us
148 149
	(stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
	doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
150

151 152
doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
	   -> ModGuts -> IO (SimplCount, ModGuts)
153 154 155 156 157
doCorePass (CoreDoSimplify mode sws)   = {-# SCC "Simplify" #-}      simplifyPgm mode sws
doCorePass CoreCSE		       = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
doCorePass CoreLiberateCase	       = {-# SCC "LiberateCase" #-}  liberateCase
doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
158
doCorePass CoreDoStaticArgs	       = {-# SCC "StaticArgs" #-}    trBindsU  doStaticArgs
159 160 161 162
doCorePass CoreDoStrictness	       = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
doCorePass CoreDoSpecConstr	       = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
163
doCorePass CoreDoGlomBinds	       = trBinds glomBinds
164
doCorePass (CoreDoVectorisation be)    = {-# SCC "Vectorise" #-}     vectorise be
165
doCorePass CoreDoPrintCore	       = observe printCore
166
doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
167 168
doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
#ifdef OLD_STRICTNESS		       
169
doCorePass CoreDoOldStrictness	       = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
170 171
#else
doCorePass CoreDoOldStrictness	       = panic "CoreDoOldStrictness"
172
#endif
173
doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
174

175
#ifdef OLD_STRICTNESS
176
doOldStrictness dfs binds
177 178 179
  = do binds1 <- saBinds dfs binds
       binds2 <- cprAnalyse dfs binds1
       return binds2
180 181
#endif

182
printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
183

184 185 186 187 188
ruleCheck phase pat hsc_env us rb guts 
  =  do let dflags = hsc_dflags hsc_env
	showPass dflags "RuleCheck"
        printDump (ruleCheckProgram phase pat rb (mg_binds guts))
	return (zeroSimplCount dflags, guts)
189

190 191 192
-- Most passes return no stats and don't change rules
trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
193
	-> IO (SimplCount, ModGuts)
194 195
trBinds do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags (mg_binds guts)
196
	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
197 198 199 200 201
  where
    dflags = hsc_dflags hsc_env

trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
202
	-> IO (SimplCount, ModGuts)
203 204
trBindsU do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags us (mg_binds guts)
205
	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
206 207 208 209 210 211
  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
212
	-> IO (SimplCount, ModGuts)
213 214
observe do_pass hsc_env us rb guts 
  = do	{ binds <- do_pass dflags (mg_binds guts)
215
	; return (zeroSimplCount dflags, guts) }
216 217
  where
    dflags = hsc_dflags hsc_env
218 219 220
\end{code}


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
%************************************************************************
%*									*
	Implicit bindings
%*									*
%************************************************************************

Note [Injecting implicit bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to inject the implict bindings right at the end, in CoreTidy.
But some of these bindings, notably record selectors, are not
constructed in an optimised form.  E.g. record selector for
	data T = MkT { x :: {-# UNPACK #-} !Int }
Then the unfolding looks like
	x = \t. case t of MkT x1 -> let x = I# x1 in x
This generates bad code unless it's first simplified a bit.
(Only matters when the selector is used curried; eg map x ys.)
See Trac #2070.

\begin{code}
getImplicitBinds :: TypeEnv -> [CoreBind]
getImplicitBinds type_env
  = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
		  ++ concatMap other_implicit_ids (typeEnvElts type_env))
	-- Put the constructor wrappers first, because
	-- other implicit bindings (notably the fromT functions arising 
	-- from generics) use the constructor wrappers.  At least that's
	-- what External Core likes
  where
    implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
    
    other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
	-- The "naughty" ones are not real functions at all
	-- They are there just so we can get decent error messages
	-- See Note  [Naughty record selectors] in MkId.lhs
    other_implicit_ids (AClass cl) = classSelIds cl
    other_implicit_ids _other      = []
    
    get_defn :: Id -> CoreBind
    get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
\end{code}

262

263 264
%************************************************************************
%*									*
265
	Dealing with rules
266 267 268
%*									*
%************************************************************************

269 270
-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
-- It attaches those rules that are for local Ids to their binders, and
271
-- returns the remainder attached to Ids in an IdSet.  
272 273

\begin{code}
274
prepareRules :: HscEnv 
275
	     -> ModGuts
276
	     -> UniqSupply
277 278
	     -> IO (RuleBase, 		-- Rule base for imported things, incl
					-- (a) rules defined in this module (orphans)
279 280 281
					-- (b) rules from other modules in home package
					-- but not things from other packages

282 283 284
		    ModGuts)		-- Modified fields are 
					--	(a) Bindings have rules attached,
					-- 	(b) Rules are now just orphan rules
285

286
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
287
	     guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
288
	     us 
289
  = do	{ let 	-- Simplify the local rules; boringly, we need to make an in-scope set
290 291
		-- from the local binders, to avoid warnings from Simplify.simplVar
	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
292
	      env	       = setInScopeSet gentleSimplEnv local_ids 
293
	      (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
294
				 (mapM (simplRule env) local_rules)
295
	      home_pkg_rules   = hptRules hsc_env (dep_mods deps)
296

297 298
		-- Find the rules for locally-defined Ids; then we can attach them
		-- to the binders in the top-level bindings
299 300 301 302 303 304 305 306 307 308 309 310 311
		-- 
		-- 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
312
	      (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
313 314
	      local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
	      binds_w_rules   = updateBinders local_rule_base binds
315

316 317 318
	      hpt_rule_base = mkRuleBase home_pkg_rules
	      imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps

319
	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
320
		(vcat [text "Local rules", pprRules better_rules,
321
		       text "",
322
		       text "Imported rules", pprRuleBase imp_rule_base])
323

324 325
	; return (imp_rule_base, guts { mg_binds = binds_w_rules, 
					mg_rules = rules_for_imps })
326
    }
327

328
updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
329
updateBinders local_rules binds
330
  = map update_bndrs binds
331
  where
332 333 334
    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]

335 336
    update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
			  Nothing    -> bndr
337 338 339
			  Just rules -> bndr `addIdSpecialisations` rules
				-- The binder might have some existing rules,
				-- arising from specialisation pragmas
340 341
\end{code}

342 343 344 345
Note [Simplifying the left-hand side of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must do some gentle simplification on the lhs (template) of each
rule.  The case that forced me to add this was the fold/build rule,
346 347 348
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.
349 350 351 352 353 354
Similarly for a LHS like
	augment g (build h) 
we do not want to get
	augment (\a. g a) (build h)
otherwise we don't match when given an argument like
	augment (\a. h a a) (build h)
355

356
\begin{code}
357
simplRule env rule@(BuiltinRule {})
358
  = return rule
359
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
360 361 362 363
  = do (env, bndrs') <- simplBinders env bndrs
       args' <- mapM (simplExprGently env) args
       rhs' <- simplExprGently env rhs
       return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
364

365 366
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
367
--	augment g (build h) 
368
-- we do not want to get
369
--	augment (\a. g a) (build h)
370
-- otherwise we don't match when given an argument like
371
--	(\a. h a a)
372 373 374 375 376 377
--
-- The simplifier does indeed do eta reduction (it's in
-- Simplify.completeLam) but only if -O is on.
\end{code}

\begin{code}
378
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
379 380 381 382 383 384
-- 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
385
--	(c) Template Haskell splices
386 387 388 389 390
--
-- 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

391 392 393 394 395
-- It's important that simplExprGently does eta reduction; see
-- Note [Simplifying the left-hand side of a RULE] above.  The
-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
-- but only if -O is on.

396 397
simplExprGently env expr = do
    expr1 <- simplExpr env (occurAnalyseExpr expr)
398
    simplExpr env (occurAnalyseExpr expr1)
399 400
\end{code}

401 402 403 404 405 406 407

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

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

435
glomBinds dflags binds
436
  = do { showPass dflags "GlomBinds" ;
437 438 439 440 441 442
	 let { recd_binds = [Rec (flattenBinds binds)] } ;
	 return recd_binds }
	-- Not much point in printing the result... 
	-- just consumes output bandwidth
\end{code}

443

444 445 446 447 448 449 450
%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
451
simplifyPgm :: SimplifierMode
452
	    -> [SimplifierSwitch]
453
	    -> HscEnv
454
	    -> UniqSupply
455 456
	    -> RuleBase
	    -> ModGuts
457
	    -> IO (SimplCount, ModGuts)  -- New bindings
458

459
simplifyPgm mode switches hsc_env us imp_rule_base guts
460
  = do {
461
	showPass dflags "Simplify";
462

463 464
	(termination_msg, it_count, counts_out, binds') 
	   <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
465

466
	dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
467 468 469 470 471
		  "Simplifier statistics"
		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
			 text "",
			 pprSimplCount counts_out]);

472 473 474
	endPassIf dump_phase dflags
                  ("Simplify phase " ++ phase_info ++ " done")
                  Opt_D_dump_simpl_phases binds';
475

476
	return (counts_out, guts { mg_binds = binds' })
477 478
    }
  where
479 480
    dflags 	   = hsc_dflags hsc_env
    phase_info	   = case mode of
481 482 483 484 485
		   	  SimplGently     -> "gentle"
		   	  SimplPhase n ss -> shows n
                                           . showString " ["
                                           . showString (concat $ intersperse "," ss)
                                           $ "]"
486 487

    dump_phase     = shouldDumpSimplPhase dflags mode
488 489 490
		   
    sw_chkr	   = isAmongSimpl switches
    max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
491
 
492
    do_iteration us iteration_no counts binds
493 494 495
	-- 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
496 497 498 499
      =  WARN(debugIsOn && (max_iterations > 2),
                text ("Simplifier still going after " ++
				show max_iterations ++
			    	" iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
500 501
		-- Subtract 1 from iteration_no to get the
		-- number of iterations we actually completed
502
	    return ("Simplifier bailed out", iteration_no - 1, counts, binds)
503

504 505
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
506
      | let sz = coreBindsSize binds in sz == sz
507 508
      = do {
		-- Occurrence analysis
509
	   let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
510
	   dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
511 512
		     (pprCoreBindings tagged_binds);

513 514 515 516 517
	   	-- 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
518 519
	   eps <- hscEPS hsc_env ;
	   let	{ rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
520
		; simpl_env  = mkSimplEnv mode sw_chkr 
521
		; simpl_binds = {-# SCC "SimplTopBinds" #-} 
522 523
				simplTopBinds simpl_env tagged_binds
		; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
524 525
	   
		-- Simplify the program
526 527 528 529 530 531 532
		-- 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
533
		-- 	case t of {(_,counts') -> if counts'=0 then ... }
534 535
		-- So the conditional didn't force counts', because the
		-- selection got duplicated.  Sigh!
536
	   case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
537
	  	(binds', counts') -> do {
538

539
	   let	{ all_counts = counts `plusSimplCount` counts'
540
		; herald     = "Simplifier phase " ++ phase_info ++ 
541 542 543
			      ", iteration " ++ show iteration_no ++
			      " out of " ++ show max_iterations
	        } ;
544 545 546

		-- Stop if nothing happened; don't dump output
	   if isZeroSimplCount counts' then
547
		return ("Simplifier reached fixed point", iteration_no, 
548
			all_counts, binds')
549
	   else do {
550 551 552 553 554
		-- 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
555 556 557
		--
		-- ToDo: alas, this means that indirection-shorting does not happen at all
		--	 if the simplifier does nothing (not common, I know, but unsavoury)
558
	   let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
559 560

		-- Dump the result of this iteration
561
	   dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
562
		         (pprSimplCount counts') ;
563
	   endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
564

565
		-- Loop
566
  	   do_iteration us2 (iteration_no + 1) all_counts binds''
567
	}  } } }
568 569 570
      where
  	  (us1, us2) = splitUniqSupply us
\end{code}
571 572 573 574


%************************************************************************
%*									*
575
		Shorting out indirections
576 577 578
%*									*
%************************************************************************

579
If we have this:
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 620 621 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 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689

	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
690 691
  | no_need_to_flatten	  = binds'			-- See Note [Rules and indirect-zapping]
  | otherwise 		  = [Rec (flattenBinds binds')]	-- for this no_need_to_flatten stuff
692 693
  where
    ind_env 	       = makeIndEnv binds
694 695
    exp_ids 	       = varSetElems ind_env	-- These exported Ids are the subjects
    exp_id_set	       = mkVarSet exp_ids	-- of the indirection-elimination
696
    no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738
    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
739
	if isEmptySpecInfo (specInfo (idInfo exported_id)) 	-- Only if no rules
740 741 742 743 744 745 746 747 748 749 750 751 752
	then True	-- See note on "Messing up rules"
	else 
#ifdef DEBUG 
          pprTrace "shortMeOut:" (ppr exported_id)
#endif
                                                False
-}
    else
	False


-----------------
transferIdInfo :: Id -> Id -> Id
753 754 755 756 757 758
-- 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.
759 760 761 762 763 764
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
765
				 `setInlinePragInfo`	inlinePragInfo local_info
766 767 768 769 770
				 `setSpecInfo`	        addSpecInfo (specInfo exp_info) new_info
    new_info = setSpecInfoHead (idName exported_id) 
			       (specInfo local_info)
	-- Remember to set the function-name field of the
	-- rules as we transfer them from one function to another
771
\end{code}