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 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module SimplCore ( core2core, simplifyExpr ) where
  15
  16 #include "HsVersions.h"
  17
  18 import DynFlags         ( CoreToDo(..), SimplifierSwitch(..),
  19                           SimplifierMode(..), DynFlags, DynFlag(..), dopt,
  20                           getCoreToDo )
  21 import CoreSyn
  22 import HscTypes         ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
  23                           Dependencies( dep_mods ),
  24                           hscEPS, hptRules )
  25 import CSE              ( cseProgram )
  26 import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
  27                           extendRuleBaseList, pprRuleBase, ruleCheckProgram,
  28                           addSpecInfo, addIdSpecialisations )
  29 import PprCore          ( pprCoreBindings, pprCoreExpr, pprRules )
  30 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
  31 import IdInfo           ( setNewStrictnessInfo, newStrictnessInfo,
  32                           setWorkerInfo, workerInfo, setSpecInfoHead,
  33                           setInlinePragInfo, inlinePragInfo,
  34                           setSpecInfo, specInfo, specInfoRules )
  35 import CoreUtils        ( coreBindsSize )
  36 import Simplify         ( simplTopBinds, simplExpr )
  37 import SimplEnv         ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
  38 import SimplMonad
  39 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  40 import CoreLint         ( endPass, endIteration )
  41 import FloatIn          ( floatInwards )
  42 import FloatOut         ( floatOutwards )
  43 import FamInstEnv
  44 import Id               ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
  45                           idSpecialisation, idName )
  46 import VarSet
  47 import VarEnv
  48 import NameEnv          ( lookupNameEnv )
  49 import LiberateCase     ( liberateCase )
  50 import SAT              ( doStaticArgs )
  51 import Specialise       ( specProgram)
  52 import SpecConstr       ( specConstrProgram)
  53 import DmdAnal          ( dmdAnalPgm )
  54 import WorkWrap         ( wwTopBinds )
  55 #ifdef OLD_STRICTNESS
  56 import StrictAnal       ( saBinds )
  57 import CprAnalyse       ( cprAnalyse )
  58 #endif
  59 import Vectorise        ( vectorise )
  60
  61 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  62 import IO               ( hPutStr, stderr )
  63 import Outputable
  64 import List             ( partition )
  65 import Maybes           ( orElse )
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{The driver for the simplifier}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 core2core :: HscEnv
  76           -> ModGuts
  77           -> IO ModGuts
  78
  79 core2core hsc_env guts
  80   = do
  81         let dflags = hsc_dflags hsc_env
  82             core_todos = getCoreToDo dflags
  83
  84         us <- mkSplitUniqSupply 's'
  85         let (cp_us, ru_us) = splitUniqSupply us
  86
  87                 -- COMPUTE THE RULE BASE TO USE
  88         (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
  89
  90                 -- DO THE BUSINESS
  91         (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
  92                                         (zeroSimplCount dflags)
  93                                         guts' core_todos
  94
  95         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  96                   "Grand total simplifier statistics"
  97                   (pprSimplCount stats)
  98
  99         return guts''
 100
 101
 102 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 103              -> CoreExpr
 104              -> IO CoreExpr
 105 -- simplifyExpr is called by the driver to simplify an
 106 -- expression typed in at the interactive prompt
 107 simplifyExpr dflags expr
 108   = do  {
 109         ; showPass dflags "Simplify"
 110
 111         ; us <-  mkSplitUniqSupply 's'
 112
 113         ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 114                                  simplExprGently gentleSimplEnv expr
 115
 116         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 117                         (pprCoreExpr expr')
 118
 119         ; return expr'
 120         }
 121
 122 gentleSimplEnv :: SimplEnv
 123 gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
 124
 125 doCorePasses :: HscEnv
 126              -> RuleBase        -- the imported main rule base
 127              -> UniqSupply      -- uniques
 128              -> SimplCount      -- simplifier stats
 129              -> ModGuts         -- local binds in (with rules attached)
 130              -> [CoreToDo]      -- which passes to do
 131              -> IO (SimplCount, ModGuts)
 132
 133 doCorePasses hsc_env rb us stats guts []
 134   = return (stats, guts)
 135
 136 doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2)
 137   = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2)
 138
 139 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
 140   = do
 141         let (us1, us2) = splitUniqSupply us
 142         (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
 143         doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
 144
 145 doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
 146            -> ModGuts -> IO (SimplCount, ModGuts)
 147 doCorePass (CoreDoSimplify mode sws)   = {-# SCC "Simplify" #-}      simplifyPgm mode sws
 148 doCorePass CoreCSE                     = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
 149 doCorePass CoreLiberateCase            = {-# SCC "LiberateCase" #-}  liberateCase
 150 doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
 151 doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
 152 doCorePass CoreDoStaticArgs            = {-# SCC "StaticArgs" #-}    trBinds  doStaticArgs
 153 doCorePass CoreDoStrictness            = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
 154 doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
 155 doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
 156 doCorePass CoreDoSpecConstr            = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
 157 doCorePass CoreDoGlomBinds             = trBinds glomBinds
 158 doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
 159 doCorePass CoreDoPrintCore             = observe printCore
 160 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
 161 doCorePass CoreDoNothing               = observe (\ _ _ -> return ())
 162 #ifdef OLD_STRICTNESS
 163 doCorePass CoreDoOldStrictness         = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
 164 #else
 165 doCorePass CoreDoOldStrictness         = panic "CoreDoOldStrictness"
 166 #endif
 167 doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
 168
 169 #ifdef OLD_STRICTNESS
 170 doOldStrictness dfs binds
 171   = do binds1 <- saBinds dfs binds
 172        binds2 <- cprAnalyse dfs binds1
 173        return binds2
 174 #endif
 175
 176 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 177
 178 ruleCheck phase pat hsc_env us rb guts
 179   =  do let dflags = hsc_dflags hsc_env
 180         showPass dflags "RuleCheck"
 181         printDump (ruleCheckProgram phase pat rb (mg_binds guts))
 182         return (zeroSimplCount dflags, guts)
 183
 184 -- Most passes return no stats and don't change rules
 185 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 186         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 187         -> IO (SimplCount, ModGuts)
 188 trBinds do_pass hsc_env us rb guts
 189   = do  { binds' <- do_pass dflags (mg_binds guts)
 190         ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
 191   where
 192     dflags = hsc_dflags hsc_env
 193
 194 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
 195         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 196         -> IO (SimplCount, ModGuts)
 197 trBindsU do_pass hsc_env us rb guts
 198   = do  { binds' <- do_pass dflags us (mg_binds guts)
 199         ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
 200   where
 201     dflags = hsc_dflags hsc_env
 202
 203 -- Observer passes just peek; don't modify the bindings at all
 204 observe :: (DynFlags -> [CoreBind] -> IO a)
 205         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 206         -> IO (SimplCount, ModGuts)
 207 observe do_pass hsc_env us rb guts
 208   = do  { binds <- do_pass dflags (mg_binds guts)
 209         ; return (zeroSimplCount dflags, guts) }
 210   where
 211     dflags = hsc_dflags hsc_env
 212 \end{code}
 213
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218 \subsection{Dealing with rules}
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 223 -- It attaches those rules that are for local Ids to their binders, and
 224 -- returns the remainder attached to Ids in an IdSet.
 225
 226 \begin{code}
 227 prepareRules :: HscEnv
 228              -> ModGuts
 229              -> UniqSupply
 230              -> IO (RuleBase,           -- Rule base for imported things, incl
 231                                         -- (a) rules defined in this module (orphans)
 232                                         -- (b) rules from other modules in home package
 233                                         -- but not things from other packages
 234
 235                     ModGuts)            -- Modified fields are
 236                                         --      (a) Bindings have rules attached,
 237                                         --      (b) Rules are now just orphan rules
 238
 239 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 240              guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
 241              us
 242   = do  { let   -- Simplify the local rules; boringly, we need to make an in-scope set
 243                 -- from the local binders, to avoid warnings from Simplify.simplVar
 244               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 245               env              = setInScopeSet gentleSimplEnv local_ids
 246               (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 247                                  (mapM (simplRule env) local_rules)
 248               home_pkg_rules   = hptRules hsc_env (dep_mods deps)
 249
 250                 -- Find the rules for locally-defined Ids; then we can attach them
 251                 -- to the binders in the top-level bindings
 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               (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
 266               local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
 267               binds_w_rules   = updateBinders local_rule_base binds
 268
 269               hpt_rule_base = mkRuleBase home_pkg_rules
 270               imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
 271
 272         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 273                 (vcat [text "Local rules", pprRules better_rules,
 274                        text "",
 275                        text "Imported rules", pprRuleBase imp_rule_base])
 276
 277         ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
 278                                         mg_rules = rules_for_imps })
 279     }
 280
 281 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
 282 updateBinders local_rules binds
 283   = map update_bndrs binds
 284   where
 285     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 286     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 287
 288     update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
 289                           Nothing    -> bndr
 290                           Just rules -> bndr `addIdSpecialisations` rules
 291                                 -- The binder might have some existing rules,
 292                                 -- arising from specialisation pragmas
 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@(BuiltinRule {})
 304   = return rule
 305 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
 306   = do (env, bndrs') <- simplBinders env bndrs
 307        args' <- mapM (simplExprGently env) args
 308        rhs' <- simplExprGently env rhs
 309        return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = 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 = do
 337     expr1 <- simplExpr env (occurAnalyseExpr expr)
 338     simplExpr env (occurAnalyseExpr 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, ModGuts)  -- New bindings
 398
 399 simplifyPgm mode switches hsc_env us imp_rule_base guts
 400   = do {
 401         showPass dflags "Simplify";
 402
 403         (termination_msg, it_count, counts_out, binds')
 404            <- do_iteration us 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 phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds';
 414
 415         return (counts_out, 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 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.  Size = " ++ show (coreBindsSize binds) ++ "\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, 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                 -- We need to do this regularly, because simplification can
 455                 -- poke on IdInfo thunks, which in turn brings in new rules
 456                 -- behind the scenes.  Otherwise there's a danger we'll simply
 457                 -- miss the rules for Ids hidden inside imported inlinings
 458            eps <- hscEPS hsc_env ;
 459            let  { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
 460                 ; simpl_env  = mkSimplEnv mode sw_chkr
 461                 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
 462                                 simplTopBinds simpl_env tagged_binds
 463                 ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
 464
 465                 -- Simplify the program
 466                 -- We do this with a *case* not a *let* because lazy pattern
 467                 -- matching bit us with bad space leak!
 468                 -- With a let, we ended up with
 469                 --   let
 470                 --      t = initSmpl ...
 471                 --      counts' = snd t
 472                 --   in
 473                 --      case t of {(_,counts') -> if counts'=0 then ... }
 474                 -- So the conditional didn't force counts', because the
 475                 -- selection got duplicated.  Sigh!
 476            case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
 477                 (binds', counts') -> do {
 478
 479            let  { all_counts = counts `plusSimplCount` counts'
 480                 ; herald     = "Simplifier phase " ++ phase_info ++
 481                               ", iteration " ++ show iteration_no ++
 482                               " out of " ++ show max_iterations
 483                 } ;
 484
 485                 -- Stop if nothing happened; don't dump output
 486            if isZeroSimplCount counts' then
 487                 return ("Simplifier reached fixed point", iteration_no,
 488                         all_counts, binds')
 489            else do {
 490                 -- Short out indirections
 491                 -- We do this *after* at least one run of the simplifier
 492                 -- because indirection-shorting uses the export flag on *occurrences*
 493                 -- and that isn't guaranteed to be ok until after the first run propagates
 494                 -- stuff from the binding site to its occurrences
 495                 --
 496                 -- ToDo: alas, this means that indirection-shorting does not happen at all
 497                 --       if the simplifier does nothing (not common, I know, but unsavoury)
 498            let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
 499
 500                 -- Dump the result of this iteration
 501            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 502                          (pprSimplCount counts') ;
 503            endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
 504
 505                 -- Loop
 506            do_iteration us2 (iteration_no + 1) all_counts binds''
 507         }  } } }
 508       where
 509           (us1, us2) = splitUniqSupply us
 510 \end{code}
 511
 512
 513 %************************************************************************
 514 %*                                                                      *
 515                 Shorting out indirections
 516 %*                                                                      *
 517 %************************************************************************
 518
 519 If we have this:
 520
 521         x_local = <expression>
 522         ...bindings...
 523         x_exported = x_local
 524
 525 where x_exported is exported, and x_local is not, then we replace it with this:
 526
 527         x_exported = <expression>
 528         x_local = x_exported
 529         ...bindings...
 530
 531 Without this we never get rid of the x_exported = x_local thing.  This
 532 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 533 makes strictness information propagate better.  This used to happen in
 534 the final phase, but it's tidier to do it here.
 535
 536 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 537 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 538
 539 RULES: we want to *add* any RULES for x_local to x_exported.
 540
 541 Note [Rules and indirection-zapping]
 542 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 543 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
 544 Then the things mentioned can be out of scope!  Solution
 545  a) Make sure that in this pass the usage-info from x_exported is
 546         available for ...bindings...
 547  b) If there are any such RULES, rec-ify the entire top-level.
 548     It'll get sorted out next time round
 549
 550 Messing up the rules
 551 ~~~~~~~~~~~~~~~~~~~~
 552 The example that went bad on me at one stage was this one:
 553
 554     iterate :: (a -> a) -> a -> [a]
 555         [Exported]
 556     iterate = iterateList
 557
 558     iterateFB c f x = x `c` iterateFB c f (f x)
 559     iterateList f x =  x : iterateList f (f x)
 560         [Not exported]
 561
 562     {-# RULES
 563     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 564     "iterateFB"                 iterateFB (:) = iterateList
 565      #-}
 566
 567 This got shorted out to:
 568
 569     iterateList :: (a -> a) -> a -> [a]
 570     iterateList = iterate
 571
 572     iterateFB c f x = x `c` iterateFB c f (f x)
 573     iterate f x =  x : iterate f (f x)
 574
 575     {-# RULES
 576     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 577     "iterateFB"                 iterateFB (:) = iterate
 578      #-}
 579
 580 And now we get an infinite loop in the rule system
 581         iterate f x -> build (\cn -> iterateFB c f x)
 582                     -> iterateFB (:) f x
 583                     -> iterate f x
 584
 585 Tiresome old solution:
 586         don't do shorting out if f has rewrite rules (see shortableIdInfo)
 587
 588 New solution (I think):
 589         use rule switching-off pragmas to get rid
 590         of iterateList in the first place
 591
 592
 593 Other remarks
 594 ~~~~~~~~~~~~~
 595 If more than one exported thing is equal to a local thing (i.e., the
 596 local thing really is shared), then we do one only:
 597 \begin{verbatim}
 598         x_local = ....
 599         x_exported1 = x_local
 600         x_exported2 = x_local
 601 ==>
 602         x_exported1 = ....
 603
 604         x_exported2 = x_exported1
 605 \end{verbatim}
 606
 607 We rely on prior eta reduction to simplify things like
 608 \begin{verbatim}
 609         x_exported = /\ tyvars -> x_local tyvars
 610 ==>
 611         x_exported = x_local
 612 \end{verbatim}
 613 Hence,there's a possibility of leaving unchanged something like this:
 614 \begin{verbatim}
 615         x_local = ....
 616         x_exported1 = x_local Int
 617 \end{verbatim}
 618 By the time we've thrown away the types in STG land this
 619 could be eliminated.  But I don't think it's very common
 620 and it's dangerous to do this fiddling in STG land
 621 because we might elminate a binding that's mentioned in the
 622 unfolding for something.
 623
 624 \begin{code}
 625 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
 626
 627 shortOutIndirections :: [CoreBind] -> [CoreBind]
 628 shortOutIndirections binds
 629   | isEmptyVarEnv ind_env = binds
 630   | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
 631   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
 632   where
 633     ind_env            = makeIndEnv binds
 634     exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
 635     exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
 636     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
 637     binds'             = concatMap zap binds
 638
 639     zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
 640     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 641
 642     zapPair (bndr, rhs)
 643         | bndr `elemVarSet` exp_id_set             = []
 644         | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
 645                                                       (bndr, Var exp_id)]
 646         | otherwise                                = [(bndr,rhs)]
 647
 648 makeIndEnv :: [CoreBind] -> IndEnv
 649 makeIndEnv binds
 650   = foldr add_bind emptyVarEnv binds
 651   where
 652     add_bind :: CoreBind -> IndEnv -> IndEnv
 653     add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
 654     add_bind (Rec pairs)              env = foldr add_pair env pairs
 655
 656     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
 657     add_pair (exported_id, Var local_id) env
 658         | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
 659     add_pair (exported_id, rhs) env
 660         = env
 661
 662 shortMeOut ind_env exported_id local_id
 663 -- The if-then-else stuff is just so I can get a pprTrace to see
 664 -- how often I don't get shorting out becuase of IdInfo stuff
 665   = if isExportedId exported_id &&              -- Only if this is exported
 666
 667        isLocalId local_id &&                    -- Only if this one is defined in this
 668                                                 --      module, so that we *can* change its
 669                                                 --      binding to be the exported thing!
 670
 671        not (isExportedId local_id) &&           -- Only if this one is not itself exported,
 672                                                 --      since the transformation will nuke it
 673
 674        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
 675     then
 676         True
 677
 678 {- No longer needed
 679         if isEmptySpecInfo (specInfo (idInfo exported_id))      -- Only if no rules
 680         then True       -- See note on "Messing up rules"
 681         else
 682 #ifdef DEBUG
 683           pprTrace "shortMeOut:" (ppr exported_id)
 684 #endif
 685                                                 False
 686 -}
 687     else
 688         False
 689
 690
 691 -----------------
 692 transferIdInfo :: Id -> Id -> Id
 693 -- If we have
 694 --      lcl_id = e; exp_id = lcl_id
 695 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 696 --      gbl_id = e; lcl_id = gbl_id
 697 -- Instead, transfer IdInfo from lcl_id to exp_id
 698 -- Overwriting, rather than merging, seems to work ok.
 699 transferIdInfo exported_id local_id
 700   = modifyIdInfo transfer exported_id
 701   where
 702     local_info = idInfo local_id
 703     transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
 704                                  `setWorkerInfo`        workerInfo local_info
 705                                  `setInlinePragInfo`    inlinePragInfo local_info
 706                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
 707     new_info = setSpecInfoHead (idName exported_id)
 708                                (specInfo local_info)
 709         -- Remember to set the function-name field of the
 710         -- rules as we transfer them from one function to another
 711 \end{code}