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