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