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