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