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