compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[SimplCore]{Driver for simplifying @Core@ programs}
   5
   6 \begin{code}
   7 module SimplCore ( core2core, simplifyExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import DynFlags         ( CoreToDo(..), SimplifierSwitch(..),
  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 import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
  20                           extendRuleBaseList, pprRuleBase, ruleCheckProgram,
  21                           addSpecInfo, addIdSpecialisations )
  22 import PprCore          ( pprCoreBindings, pprCoreExpr, pprRules )
  23 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
  24 import IdInfo           ( setNewStrictnessInfo, newStrictnessInfo,
  25                           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 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  33 import CoreLint         ( endPass )
  34 import FloatIn          ( floatInwards )
  35 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 import LiberateCase     ( liberateCase )
  42 import SAT              ( doStaticArgs )
  43 import Specialise       ( specProgram)
  44 import SpecConstr       ( specConstrProgram)
  45 import DmdAnal          ( dmdAnalPgm )
  46 import WorkWrap         ( wwTopBinds )
  47 #ifdef OLD_STRICTNESS
  48 import StrictAnal       ( saBinds )
  49 import CprAnalyse       ( cprAnalyse )
  50 #endif
  51
  52 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  53 import IO               ( hPutStr, stderr )
  54 import Outputable
  55 import List             ( partition )
  56 import Maybes           ( orElse )
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{The driver for the simplifier}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 \begin{code}
  66 core2core :: HscEnv
  67           -> ModGuts
  68           -> 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                   "Grand total simplifier statistics"
  88                   (pprSimplCount stats)
  89
  90         return guts''
  91
  92
  93 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
  94              -> CoreExpr
  95              -> IO CoreExpr
  96 -- simplifyExpr is called by the driver to simplify an
  97 -- expression typed in at the interactive prompt
  98 simplifyExpr dflags expr
  99   = do  {
 100         ; showPass dflags "Simplify"
 101
 102         ; us <-  mkSplitUniqSupply 's'
 103
 104         ; let (expr', _counts) = initSmpl dflags us $
 105                                  simplExprGently gentleSimplEnv expr
 106
 107         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 108                         (pprCoreExpr expr')
 109
 110         ; return expr'
 111         }
 112
 113 gentleSimplEnv :: SimplEnv
 114 gentleSimplEnv = mkSimplEnv SimplGently
 115                             (isAmongSimpl [])
 116                             emptyRuleBase
 117
 118 doCorePasses :: HscEnv
 119              -> RuleBase        -- the imported main rule base
 120              -> UniqSupply      -- uniques
 121              -> SimplCount      -- simplifier stats
 122              -> 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 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
 130   = do
 131         let (us1, us2) = splitUniqSupply us
 132         (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
 133         doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
 134
 135 doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
 136 doCorePass CoreCSE                     = _scc_ "CommonSubExpr" trBinds  cseProgram
 137 doCorePass CoreLiberateCase            = _scc_ "LiberateCase"  liberateCase
 138 doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
 139 doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
 140 doCorePass CoreDoStaticArgs            = _scc_ "StaticArgs"    trBinds  doStaticArgs
 141 doCorePass CoreDoStrictness            = _scc_ "Stranal"       trBinds  dmdAnalPgm
 142 doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
 143 doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
 144 doCorePass CoreDoSpecConstr            = _scc_ "SpecConstr"    trBindsU specConstrProgram
 145 doCorePass CoreDoGlomBinds             = trBinds glomBinds
 146 doCorePass CoreDoPrintCore             = observe printCore
 147 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
 148 doCorePass CoreDoNothing               = observe (\ _ _ -> return ())
 149 #ifdef OLD_STRICTNESS
 150 doCorePass CoreDoOldStrictness         = _scc_ "OldStrictness" trBinds doOldStrictness
 151 #else
 152 doCorePass CoreDoOldStrictness         = panic "CoreDoOldStrictness"
 153 #endif
 154
 155 #ifdef OLD_STRICTNESS
 156 doOldStrictness dfs binds
 157   = do binds1 <- saBinds dfs binds
 158        binds2 <- cprAnalyse dfs binds1
 159        return binds2
 160 #endif
 161
 162 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 163
 164 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
 165                                       printDump (ruleCheckProgram phase pat binds)
 166
 167 -- Most passes return no stats and don't change rules
 168 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 169         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 170         -> IO (SimplCount, ModGuts)
 171 trBinds do_pass hsc_env us rb guts
 172   = do  { binds' <- do_pass dflags (mg_binds guts)
 173         ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
 174   where
 175     dflags = hsc_dflags hsc_env
 176
 177 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
 178         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 179         -> IO (SimplCount, ModGuts)
 180 trBindsU do_pass hsc_env us rb guts
 181   = do  { binds' <- do_pass dflags us (mg_binds guts)
 182         ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
 183   where
 184     dflags = hsc_dflags hsc_env
 185
 186 -- Observer passes just peek; don't modify the bindings at all
 187 observe :: (DynFlags -> [CoreBind] -> IO a)
 188         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 189         -> IO (SimplCount, ModGuts)
 190 observe do_pass hsc_env us rb guts
 191   = do  { binds <- do_pass dflags (mg_binds guts)
 192         ; return (zeroSimplCount dflags, guts) }
 193   where
 194     dflags = hsc_dflags hsc_env
 195 \end{code}
 196
 197
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection{Dealing with rules}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 206 -- It attaches those rules that are for local Ids to their binders, and
 207 -- returns the remainder attached to Ids in an IdSet.
 208
 209 \begin{code}
 210 prepareRules :: HscEnv
 211              -> ModGuts
 212              -> UniqSupply
 213              -> IO (RuleBase,           -- Rule base for imported things, incl
 214                                         -- (a) rules defined in this module (orphans)
 215                                         -- (b) rules from other modules in home package
 216                                         -- but not things from other packages
 217
 218                     ModGuts)            -- Modified fields are
 219                                         --      (a) Bindings have rules attached,
 220                                         --      (b) Rules are now just orphan rules
 221
 222 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 223              guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
 224              us
 225   = do  { let   -- Simplify the local rules; boringly, we need to make an in-scope set
 226                 -- from the local binders, to avoid warnings from Simplify.simplVar
 227               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 228               env              = setInScopeSet gentleSimplEnv local_ids
 229               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 230               home_pkg_rules   = hptRules hsc_env (dep_mods deps)
 231
 232                 -- Find the rules for locally-defined Ids; then we can attach them
 233                 -- to the binders in the top-level bindings
 234                 --
 235                 -- Reason
 236                 --      - It makes the rules easier to look up
 237                 --      - It means that transformation rules and specialisations for
 238                 --        locally defined Ids are handled uniformly
 239                 --      - It keeps alive things that are referred to only from a rule
 240                 --        (the occurrence analyser knows about rules attached to Ids)
 241                 --      - It makes sure that, when we apply a rule, the free vars
 242                 --        of the RHS are more likely to be in scope
 243                 --      - The imported rules are carried in the in-scope set
 244                 --        which is extended on each iteration by the new wave of
 245                 --        local binders; any rules which aren't on the binding will
 246                 --        thereby get dropped
 247               (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
 248               local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
 249               binds_w_rules   = updateBinders local_rule_base binds
 250
 251               hpt_rule_base = mkRuleBase home_pkg_rules
 252               imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
 253
 254         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 255                 (vcat [text "Local rules", pprRules better_rules,
 256                        text "",
 257                        text "Imported rules", pprRuleBase imp_rule_base])
 258
 259         ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
 260                                         mg_rules = rules_for_imps })
 261     }
 262
 263 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
 264 updateBinders local_rules binds
 265   = map update_bndrs binds
 266   where
 267     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 268     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 269
 270     update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
 271                           Nothing    -> bndr
 272                           Just rules -> bndr `addIdSpecialisations` rules
 273                                 -- The binder might have some existing rules,
 274                                 -- arising from specialisation pragmas
 275 \end{code}
 276
 277
 278 We must do some gentle simplification on the template (but not the RHS)
 279 of each rule.  The case that forced me to add this was the fold/build rule,
 280 which without simplification looked like:
 281         fold k z (build (/\a. g a))  ==>  ...
 282 This doesn't match unless you do eta reduction on the build argument.
 283
 284 \begin{code}
 285 simplRule env rule@(BuiltinRule {})
 286   = returnSmpl rule
 287 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
 288   = simplBinders env bndrs              `thenSmpl` \ (env, bndrs') ->
 289     mapSmpl (simplExprGently env) args  `thenSmpl` \ args' ->
 290     simplExprGently env rhs             `thenSmpl` \ rhs' ->
 291     returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
 292
 293 -- It's important that simplExprGently does eta reduction.
 294 -- For example, in a rule like:
 295 --      augment g (build h)
 296 -- we do not want to get
 297 --      augment (\a. g a) (build h)
 298 -- otherwise we don't match when given an argument like
 299 --      (\a. h a a)
 300 --
 301 -- The simplifier does indeed do eta reduction (it's in
 302 -- Simplify.completeLam) but only if -O is on.
 303 \end{code}
 304
 305 \begin{code}
 306 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 307 -- Simplifies an expression
 308 --      does occurrence analysis, then simplification
 309 --      and repeats (twice currently) because one pass
 310 --      alone leaves tons of crud.
 311 -- Used (a) for user expressions typed in at the interactive prompt
 312 --      (b) the LHS and RHS of a RULE
 313 --
 314 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 315 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 316 -- enforce that; it just simplifies the expression twice
 317
 318 simplExprGently env expr
 319   = simplExpr env (occurAnalyseExpr expr)       `thenSmpl` \ expr1 ->
 320     simplExpr env (occurAnalyseExpr expr1)
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection{Glomming}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 \begin{code}
 331 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 332 -- Glom all binds together in one Rec, in case any
 333 -- transformations have introduced any new dependencies
 334 --
 335 -- NB: the global invariant is this:
 336 --      *** the top level bindings are never cloned, and are always unique ***
 337 --
 338 -- We sort them into dependency order, but applying transformation rules may
 339 -- make something at the top refer to something at the bottom:
 340 --      f = \x -> p (q x)
 341 --      h = \y -> 3
 342 --
 343 --      RULE:  p (q x) = h x
 344 --
 345 -- Applying this rule makes f refer to h,
 346 -- although it doesn't appear to in the source program.
 347 -- This pass lets us control where it happens.
 348 --
 349 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 350 -- function.  It only happens for rules whose head is an imported function
 351 -- (p in the example above).  So, for example, the rule had been
 352 --      RULE: f (p x) = h x
 353 -- then the rule for f would be attached to f itself (in its IdInfo)
 354 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 355 -- analyser as free in f.
 356
 357 glomBinds dflags binds
 358   = do { showPass dflags "GlomBinds" ;
 359          let { recd_binds = [Rec (flattenBinds binds)] } ;
 360          return recd_binds }
 361         -- Not much point in printing the result...
 362         -- just consumes output bandwidth
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{The driver for the simplifier}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 simplifyPgm :: SimplifierMode
 374             -> [SimplifierSwitch]
 375             -> HscEnv
 376             -> UniqSupply
 377             -> RuleBase
 378             -> ModGuts
 379             -> IO (SimplCount, ModGuts)  -- New bindings
 380
 381 simplifyPgm mode switches hsc_env us imp_rule_base guts
 382   = do {
 383         showPass dflags "Simplify";
 384
 385         (termination_msg, it_count, counts_out, binds')
 386            <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
 387
 388         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 389                    && dopt Opt_D_dump_simpl_stats dflags)
 390                   "Simplifier statistics"
 391                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 392                          text "",
 393                          pprSimplCount counts_out]);
 394
 395         endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
 396
 397         return (counts_out, guts { mg_binds = binds' })
 398     }
 399   where
 400     dflags         = hsc_dflags hsc_env
 401     phase_info     = case mode of
 402                           SimplGently  -> "gentle"
 403                           SimplPhase n -> show n
 404
 405     sw_chkr        = isAmongSimpl switches
 406     max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 407
 408     do_iteration us iteration_no counts binds
 409         -- iteration_no is the number of the iteration we are
 410         -- about to begin, with '1' for the first
 411       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 412       = do {
 413 #ifdef DEBUG
 414             if  max_iterations > 2 then
 415                 hPutStr stderr ("NOTE: Simplifier still going after " ++
 416                                 show max_iterations ++
 417                                 " iterations; bailing out.\n")
 418             else
 419                 return ();
 420 #endif
 421                 -- Subtract 1 from iteration_no to get the
 422                 -- number of iterations we actually completed
 423             return ("Simplifier baled out", iteration_no - 1, counts, binds)
 424         }
 425
 426       -- Try and force thunks off the binds; significantly reduces
 427       -- space usage, especially with -O.  JRS, 000620.
 428       | let sz = coreBindsSize binds in sz == sz
 429       = do {
 430                 -- Occurrence analysis
 431            let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
 432            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 433                      (pprCoreBindings tagged_binds);
 434
 435                 -- Get any new rules, and extend the rule base
 436                 -- We need to do this regularly, because simplification can
 437                 -- poke on IdInfo thunks, which in turn brings in new rules
 438                 -- behind the scenes.  Otherwise there's a danger we'll simply
 439                 -- miss the rules for Ids hidden inside imported inlinings
 440            eps <- hscEPS hsc_env ;
 441            let  { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
 442                 ; simpl_env  = mkSimplEnv mode sw_chkr rule_base' } ;
 443
 444                 -- Simplify the program
 445                 -- We do this with a *case* not a *let* because lazy pattern
 446                 -- matching bit us with bad space leak!
 447                 -- With a let, we ended up with
 448                 --   let
 449                 --      t = initSmpl ...
 450                 --      counts' = snd t
 451                 --   in
 452                 --      case t of {(_,counts') -> if counts'=0 then ... }
 453                 -- So the conditional didn't force counts', because the
 454                 -- selection got duplicated.  Sigh!
 455            case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
 456                 (binds', counts') -> do {
 457
 458            let  { all_counts = counts `plusSimplCount` counts'
 459                 ; herald     = "Simplifier phase " ++ phase_info ++
 460                               ", iteration " ++ show iteration_no ++
 461                               " out of " ++ show max_iterations
 462                 } ;
 463
 464                 -- Stop if nothing happened; don't dump output
 465            if isZeroSimplCount counts' then
 466                 return ("Simplifier reached fixed point", iteration_no,
 467                         all_counts, binds')
 468            else do {
 469                 -- Short out indirections
 470                 -- We do this *after* at least one run of the simplifier
 471                 -- because indirection-shorting uses the export flag on *occurrences*
 472                 -- and that isn't guaranteed to be ok until after the first run propagates
 473                 -- stuff from the binding site to its occurrences
 474                 --
 475                 -- ToDo: alas, this means that indirection-shorting does not happen at all
 476                 --       if the simplifier does nothing (not common, I know, but unsavoury)
 477            let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
 478
 479                 -- Dump the result of this iteration
 480            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 481                          (pprSimplCount counts') ;
 482            endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
 483
 484                 -- Loop
 485            do_iteration us2 (iteration_no + 1) all_counts binds''
 486         }  } } }
 487       where
 488           (us1, us2) = splitUniqSupply us
 489 \end{code}
 490
 491
 492 %************************************************************************
 493 %*                                                                      *
 494                 Shorting out indirections
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 If we have this:
 499
 500         x_local = <expression>
 501         ...bindings...
 502         x_exported = x_local
 503
 504 where x_exported is exported, and x_local is not, then we replace it with this:
 505
 506         x_exported = <expression>
 507         x_local = x_exported
 508         ...bindings...
 509
 510 Without this we never get rid of the x_exported = x_local thing.  This
 511 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 512 makes strictness information propagate better.  This used to happen in
 513 the final phase, but it's tidier to do it here.
 514
 515 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 516 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 517
 518 RULES: we want to *add* any RULES for x_local to x_exported.
 519
 520 Note [Rules and indirection-zapping]
 521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 522 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
 523 Then the things mentioned can be out of scope!  Solution
 524  a) Make sure that in this pass the usage-info from x_exported is
 525         available for ...bindings...
 526  b) If there are any such RULES, rec-ify the entire top-level.
 527     It'll get sorted out next time round
 528
 529 Messing up the rules
 530 ~~~~~~~~~~~~~~~~~~~~
 531 The example that went bad on me at one stage was this one:
 532
 533     iterate :: (a -> a) -> a -> [a]
 534         [Exported]
 535     iterate = iterateList
 536
 537     iterateFB c f x = x `c` iterateFB c f (f x)
 538     iterateList f x =  x : iterateList f (f x)
 539         [Not exported]
 540
 541     {-# RULES
 542     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 543     "iterateFB"                 iterateFB (:) = iterateList
 544      #-}
 545
 546 This got shorted out to:
 547
 548     iterateList :: (a -> a) -> a -> [a]
 549     iterateList = iterate
 550
 551     iterateFB c f x = x `c` iterateFB c f (f x)
 552     iterate f x =  x : iterate f (f x)
 553
 554     {-# RULES
 555     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 556     "iterateFB"                 iterateFB (:) = iterate
 557      #-}
 558
 559 And now we get an infinite loop in the rule system
 560         iterate f x -> build (\cn -> iterateFB c f x)
 561                     -> iterateFB (:) f x
 562                     -> iterate f x
 563
 564 Tiresome old solution:
 565         don't do shorting out if f has rewrite rules (see shortableIdInfo)
 566
 567 New solution (I think):
 568         use rule switching-off pragmas to get rid
 569         of iterateList in the first place
 570
 571
 572 Other remarks
 573 ~~~~~~~~~~~~~
 574 If more than one exported thing is equal to a local thing (i.e., the
 575 local thing really is shared), then we do one only:
 576 \begin{verbatim}
 577         x_local = ....
 578         x_exported1 = x_local
 579         x_exported2 = x_local
 580 ==>
 581         x_exported1 = ....
 582
 583         x_exported2 = x_exported1
 584 \end{verbatim}
 585
 586 We rely on prior eta reduction to simplify things like
 587 \begin{verbatim}
 588         x_exported = /\ tyvars -> x_local tyvars
 589 ==>
 590         x_exported = x_local
 591 \end{verbatim}
 592 Hence,there's a possibility of leaving unchanged something like this:
 593 \begin{verbatim}
 594         x_local = ....
 595         x_exported1 = x_local Int
 596 \end{verbatim}
 597 By the time we've thrown away the types in STG land this
 598 could be eliminated.  But I don't think it's very common
 599 and it's dangerous to do this fiddling in STG land
 600 because we might elminate a binding that's mentioned in the
 601 unfolding for something.
 602
 603 \begin{code}
 604 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
 605
 606 shortOutIndirections :: [CoreBind] -> [CoreBind]
 607 shortOutIndirections binds
 608   | isEmptyVarEnv ind_env = binds
 609   | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
 610   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
 611   where
 612     ind_env            = makeIndEnv binds
 613     exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
 614     exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
 615     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
 616     binds'             = concatMap zap binds
 617
 618     zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
 619     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 620
 621     zapPair (bndr, rhs)
 622         | bndr `elemVarSet` exp_id_set             = []
 623         | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
 624                                                       (bndr, Var exp_id)]
 625         | otherwise                                = [(bndr,rhs)]
 626
 627 makeIndEnv :: [CoreBind] -> IndEnv
 628 makeIndEnv binds
 629   = foldr add_bind emptyVarEnv binds
 630   where
 631     add_bind :: CoreBind -> IndEnv -> IndEnv
 632     add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
 633     add_bind (Rec pairs)              env = foldr add_pair env pairs
 634
 635     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
 636     add_pair (exported_id, Var local_id) env
 637         | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
 638     add_pair (exported_id, rhs) env
 639         = env
 640
 641 shortMeOut ind_env exported_id local_id
 642 -- The if-then-else stuff is just so I can get a pprTrace to see
 643 -- how often I don't get shorting out becuase of IdInfo stuff
 644   = if isExportedId exported_id &&              -- Only if this is exported
 645
 646        isLocalId local_id &&                    -- Only if this one is defined in this
 647                                                 --      module, so that we *can* change its
 648                                                 --      binding to be the exported thing!
 649
 650        not (isExportedId local_id) &&           -- Only if this one is not itself exported,
 651                                                 --      since the transformation will nuke it
 652
 653        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
 654     then
 655         True
 656
 657 {- No longer needed
 658         if isEmptySpecInfo (specInfo (idInfo exported_id))      -- Only if no rules
 659         then True       -- See note on "Messing up rules"
 660         else
 661 #ifdef DEBUG
 662           pprTrace "shortMeOut:" (ppr exported_id)
 663 #endif
 664                                                 False
 665 -}
 666     else
 667         False
 668
 669
 670 -----------------
 671 transferIdInfo :: Id -> Id -> Id
 672 -- If we have
 673 --      lcl_id = e; exp_id = lcl_id
 674 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 675 --      gbl_id = e; lcl_id = gbl_id
 676 -- Instead, transfer IdInfo from lcl_id to exp_id
 677 -- Overwriting, rather than merging, seems to work ok.
 678 transferIdInfo exported_id local_id
 679   = modifyIdInfo transfer exported_id
 680   where
 681     local_info = idInfo local_id
 682     transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
 683                                  `setWorkerInfo`        workerInfo local_info
 684                                  `setInlinePragInfo`    inlinePragInfo local_info
 685                                  `setSpecInfo`          addSpecInfo (specInfo exp_info)
 686                                                                     (specInfo local_info)
 687 \end{code}