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         ( DynFlags, DynFlag(..), dopt )
  19 import CoreSyn
  20 import CoreSubst
  21 import HscTypes
  22 import CSE              ( cseProgram )
  23 import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
  24                           extendRuleBaseList, pprRuleBase, pprRulesForUser,
  25                           ruleCheckProgram, rulesOfBinds,
  26                           addSpecInfo, addIdSpecialisations )
  27 import PprCore          ( pprCoreBindings, pprCoreExpr, pprRules )
  28 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
  29 import IdInfo
  30 import CoreUtils        ( coreBindsSize )
  31 import Simplify         ( simplTopBinds, simplExpr )
  32 import SimplUtils       ( simplEnvForGHCi, simplEnvForRules )
  33 import SimplEnv
  34 import SimplMonad
  35 import CoreMonad
  36 import qualified ErrUtils as Err
  37 import CoreLint
  38 import FloatIn          ( floatInwards )
  39 import FloatOut         ( floatOutwards )
  40 import FamInstEnv
  41 import Id
  42 import DataCon
  43 import TyCon            ( tyConDataCons )
  44 import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )
  45 import VarSet
  46 import VarEnv
  47 import NameEnv          ( lookupNameEnv )
  48 import LiberateCase     ( liberateCase )
  49 import SAT              ( doStaticArgs )
  50 import Specialise       ( specProgram)
  51 import SpecConstr       ( specConstrProgram)
  52 import DmdAnal          ( dmdAnalPgm )
  53 import WorkWrap         ( wwTopBinds )
  54 import Vectorise        ( vectorise )
  55 import FastString
  56 import Util
  57
  58 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  59 import Outputable
  60 import Control.Monad
  61 import Data.List
  62 import System.IO
  63 import Maybes
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection{The driver for the simplifier}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 core2core :: HscEnv -> ModGuts -> IO ModGuts
  74 core2core hsc_env guts
  75   = do { us <- mkSplitUniqSupply 's'
  76        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
  77                            doCorePasses (getCoreToDo dflags) guts
  78
  79        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  80              "Grand total simplifier statistics"
  81              (pprSimplCount stats)
  82
  83        ; return guts2 }
  84   where
  85     dflags         = hsc_dflags hsc_env
  86     home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
  87     hpt_rule_base  = mkRuleBase home_pkg_rules
  88     mod            = mg_module guts
  89     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
  90     -- This is very convienent for the users of the monad (e.g. plugins do not have to
  91     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
  92     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
  93     -- would mean our cached value would go out of date.
  94
  95
  96 type CorePass = CoreToDo
  97
  98 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
  99 doCorePasses passes guts
 100   = foldM do_pass guts passes
 101   where
 102     do_pass guts CoreDoNothing = return guts
 103     do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
 104     do_pass guts pass
 105        = do { dflags <- getDynFlags
 106             ; liftIO $ showPass dflags pass
 107             ; guts' <- doCorePass pass guts
 108             ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
 109             ; return guts' }
 110
 111 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
 112 doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
 113                                        simplifyPgm pass
 114
 115 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
 116                                        doPass cseProgram
 117
 118 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
 119                                        doPassD liberateCase
 120
 121 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
 122                                        doPass floatInwards
 123
 124 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
 125                                        doPassDUM (floatOutwards f)
 126
 127 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
 128                                        doPassU doStaticArgs
 129
 130 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
 131                                        doPassDM dmdAnalPgm
 132
 133 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
 134                                        doPassU wwTopBinds
 135
 136 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
 137                                        doPassU specProgram
 138
 139 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
 140                                        specConstrProgram
 141
 142 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
 143                                        vectorise be
 144
 145 doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
 146 doCorePass CoreDoPrintCore              = observe   printCore
 147 doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
 148 doCorePass CoreDoNothing                = return
 149 doCorePass (CoreDoPasses passes)        = doCorePasses passes
 150 \end{code}
 151
 152 %************************************************************************
 153 %*                                                                      *
 154 \subsection{Core pass combinators}
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 \begin{code}
 159 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 160
 161 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
 162 ruleCheck current_phase pat guts = do
 163     rb <- getRuleBase
 164     dflags <- getDynFlags
 165     liftIO $ Err.showPass dflags "RuleCheck"
 166     liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
 167     return guts
 168
 169
 170 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
 171 doPassDMS do_pass = doPassM $ \binds -> do
 172     dflags <- getDynFlags
 173     liftIOWithCount $ do_pass dflags binds
 174
 175 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
 176 doPassDUM do_pass = doPassM $ \binds -> do
 177     dflags <- getDynFlags
 178     us     <- getUniqueSupplyM
 179     liftIO $ do_pass dflags us binds
 180
 181 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
 182 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
 183
 184 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
 185 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
 186
 187 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
 188 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
 189
 190 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
 191 doPassU do_pass = doPassDU (const do_pass)
 192
 193 -- Most passes return no stats and don't change rules: these combinators
 194 -- let us lift them to the full blown ModGuts+CoreM world
 195 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
 196 doPassM bind_f guts = do
 197     binds' <- bind_f (mg_binds guts)
 198     return (guts { mg_binds = binds' })
 199
 200 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
 201 doPassMG bind_f guts = do
 202     binds' <- bind_f guts
 203     return (guts { mg_binds = binds' })
 204
 205 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
 206 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
 207
 208 -- Observer passes just peek; don't modify the bindings at all
 209 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
 210 observe do_pass = doPassM $ \binds -> do
 211     dflags <- getDynFlags
 212     liftIO $ do_pass dflags binds
 213     return binds
 214 \end{code}
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219         Gentle simplification
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 \begin{code}
 224 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 225              -> CoreExpr
 226              -> IO CoreExpr
 227 -- simplifyExpr is called by the driver to simplify an
 228 -- expression typed in at the interactive prompt
 229 --
 230 -- Also used by Template Haskell
 231 simplifyExpr dflags expr
 232   = do  {
 233         ; Err.showPass dflags "Simplify"
 234
 235         ; us <-  mkSplitUniqSupply 's'
 236
 237         ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 238                                  simplExprGently simplEnvForGHCi expr
 239
 240         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 241                         (pprCoreExpr expr')
 242
 243         ; return expr'
 244         }
 245
 246 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 247 -- Simplifies an expression
 248 --      does occurrence analysis, then simplification
 249 --      and repeats (twice currently) because one pass
 250 --      alone leaves tons of crud.
 251 -- Used (a) for user expressions typed in at the interactive prompt
 252 --      (b) the LHS and RHS of a RULE
 253 --      (c) Template Haskell splices
 254 --
 255 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 256 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 257 -- enforce that; it just simplifies the expression twice
 258
 259 -- It's important that simplExprGently does eta reduction; see
 260 -- Note [Simplifying the left-hand side of a RULE] above.  The
 261 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
 262 -- but only if -O is on.
 263
 264 simplExprGently env expr = do
 265     expr1 <- simplExpr env (occurAnalyseExpr expr)
 266     simplExpr env (occurAnalyseExpr expr1)
 267 \end{code}
 268
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection{Glomming}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 \begin{code}
 277 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 278 -- Glom all binds together in one Rec, in case any
 279 -- transformations have introduced any new dependencies
 280 --
 281 -- NB: the global invariant is this:
 282 --      *** the top level bindings are never cloned, and are always unique ***
 283 --
 284 -- We sort them into dependency order, but applying transformation rules may
 285 -- make something at the top refer to something at the bottom:
 286 --      f = \x -> p (q x)
 287 --      h = \y -> 3
 288 --
 289 --      RULE:  p (q x) = h x
 290 --
 291 -- Applying this rule makes f refer to h,
 292 -- although it doesn't appear to in the source program.
 293 -- This pass lets us control where it happens.
 294 --
 295 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 296 -- function.  It only happens for rules whose head is an imported function
 297 -- (p in the example above).  So, for example, the rule had been
 298 --      RULE: f (p x) = h x
 299 -- then the rule for f would be attached to f itself (in its IdInfo)
 300 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 301 -- analyser as free in f.
 302
 303 glomBinds dflags binds
 304   = do { Err.showPass dflags "GlomBinds" ;
 305          let { recd_binds = [Rec (flattenBinds binds)] } ;
 306          return recd_binds }
 307         -- Not much point in printing the result...
 308         -- just consumes output bandwidth
 309 \end{code}
 310
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection{The driver for the simplifier}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
 320 simplifyPgm pass guts
 321   = do { hsc_env <- getHscEnv
 322        ; us <- getUniqueSupplyM
 323        ; rb <- getRuleBase
 324        ; liftIOWithCount $
 325          simplifyPgmIO pass hsc_env us rb guts }
 326
 327 simplifyPgmIO :: CoreToDo
 328               -> HscEnv
 329               -> UniqSupply
 330               -> RuleBase
 331               -> ModGuts
 332               -> IO (SimplCount, ModGuts)  -- New bindings
 333
 334 simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
 335               hsc_env us hpt_rule_base
 336               guts@(ModGuts { mg_binds = binds, mg_rules = rules
 337                             , mg_fam_inst_env = fam_inst_env })
 338   = do { (termination_msg, it_count, counts_out, guts')
 339            <- do_iteration us 1 [] binds rules
 340
 341         ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
 342                   "Simplifier statistics for following pass"
 343                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 344                          blankLine,
 345                          pprSimplCount counts_out])
 346
 347         ; return (counts_out, guts')
 348     }
 349   where
 350     dflags       = hsc_dflags hsc_env
 351     dump_phase   = dumpSimplPhase dflags mode
 352     sw_chkr      = isAmongSimpl switches
 353     do_iteration :: UniqSupply
 354                  -> Int          -- Counts iterations
 355                  -> [SimplCount] -- Counts from earlier iterations, reversed
 356                  -> [CoreBind]   -- Bindings in
 357                  -> [CoreRule]   -- and orphan rules
 358                  -> IO (String, Int, SimplCount, ModGuts)
 359
 360     do_iteration us iteration_no counts_so_far binds rules
 361         -- iteration_no is the number of the iteration we are
 362         -- about to begin, with '1' for the first
 363       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 364       = WARN( debugIsOn && (max_iterations > 2)
 365             , ptext (sLit "Simplifier baling out after") <+> int max_iterations
 366               <+> ptext (sLit "iterations")
 367               <+> (brackets $ hsep $ punctuate comma $
 368                    map (int . simplCountN) (reverse counts_so_far))
 369               <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
 370
 371                 -- Subtract 1 from iteration_no to get the
 372                 -- number of iterations we actually completed
 373         return ( "Simplifier baled out", iteration_no - 1
 374                , totalise counts_so_far
 375                , guts { mg_binds = binds, mg_rules = rules } )
 376
 377       -- Try and force thunks off the binds; significantly reduces
 378       -- space usage, especially with -O.  JRS, 000620.
 379       | let sz = coreBindsSize binds in sz == sz
 380       = do {
 381                 -- Occurrence analysis
 382            let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
 383            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 384                      (pprCoreBindings tagged_binds);
 385
 386                 -- Get any new rules, and extend the rule base
 387                 -- See Note [Overall plumbing for rules] in Rules.lhs
 388                 -- We need to do this regularly, because simplification can
 389                 -- poke on IdInfo thunks, which in turn brings in new rules
 390                 -- behind the scenes.  Otherwise there's a danger we'll simply
 391                 -- miss the rules for Ids hidden inside imported inlinings
 392            eps <- hscEPS hsc_env ;
 393            let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
 394                 ; rule_base2 = extendRuleBaseList rule_base1 rules
 395                 ; simpl_env  = mkSimplEnv sw_chkr mode
 396                 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
 397                                 simplTopBinds simpl_env tagged_binds
 398                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
 399
 400                 -- Simplify the program
 401                 -- We do this with a *case* not a *let* because lazy pattern
 402                 -- matching bit us with bad space leak!
 403                 -- With a let, we ended up with
 404                 --   let
 405                 --      t = initSmpl ...
 406                 --      counts1 = snd t
 407                 --   in
 408                 --      case t of {(_,counts1) -> if counts1=0 then ... }
 409                 -- So the conditional didn't force counts1, because the
 410                 -- selection got duplicated.  Sigh!
 411            case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
 412                 (env1, counts1) -> do {
 413
 414            let  { binds1 = getFloats env1
 415                 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
 416                 } ;
 417
 418                 -- Stop if nothing happened; don't dump output
 419            if isZeroSimplCount counts1 then
 420                 return ( "Simplifier reached fixed point", iteration_no
 421                        , totalise (counts1 : counts_so_far)  -- Include "free" ticks
 422                        , guts { mg_binds = binds1, mg_rules = rules1 } )
 423            else do {
 424                 -- Short out indirections
 425                 -- We do this *after* at least one run of the simplifier
 426                 -- because indirection-shorting uses the export flag on *occurrences*
 427                 -- and that isn't guaranteed to be ok until after the first run propagates
 428                 -- stuff from the binding site to its occurrences
 429                 --
 430                 -- ToDo: alas, this means that indirection-shorting does not happen at all
 431                 --       if the simplifier does nothing (not common, I know, but unsavoury)
 432            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 433
 434                 -- Dump the result of this iteration
 435            end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
 436
 437                 -- Loop
 438            do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
 439         }  } } }
 440       where
 441         (us1, us2) = splitUniqSupply us
 442
 443         -- Remember the counts_so_far are reversed
 444         totalise :: [SimplCount] -> SimplCount
 445         totalise = foldr (\c acc -> acc `plusSimplCount` c)
 446                          (zeroSimplCount dflags)
 447
 448 -------------------
 449 end_iteration :: DynFlags -> CoreToDo -> Int
 450              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 451 -- Same as endIteration but with simplifier counts
 452 end_iteration dflags pass iteration_no counts binds rules
 453   = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
 454                    pass (ptext (sLit "Simplifier counts"))
 455                    (pprSimplCount counts)
 456
 457        ; endIteration dflags pass iteration_no binds rules }
 458 \end{code}
 459
 460
 461 %************************************************************************
 462 %*                                                                      *
 463                 Shorting out indirections
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 If we have this:
 468
 469         x_local = <expression>
 470         ...bindings...
 471         x_exported = x_local
 472
 473 where x_exported is exported, and x_local is not, then we replace it with this:
 474
 475         x_exported = <expression>
 476         x_local = x_exported
 477         ...bindings...
 478
 479 Without this we never get rid of the x_exported = x_local thing.  This
 480 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 481 makes strictness information propagate better.  This used to happen in
 482 the final phase, but it's tidier to do it here.
 483
 484 Note [Transferring IdInfo]
 485 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 486 We want to propagage any useful IdInfo on x_local to x_exported.
 487
 488 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 489 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 490
 491 RULES: we want to *add* any RULES for x_local to x_exported.
 492
 493
 494 Note [Messing up the exported Id's RULES]
 495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 496 We must be careful about discarding (obviously) or even merging the
 497 RULES on the exported Id. The example that went bad on me at one stage
 498 was this one:
 499
 500     iterate :: (a -> a) -> a -> [a]
 501         [Exported]
 502     iterate = iterateList
 503
 504     iterateFB c f x = x `c` iterateFB c f (f x)
 505     iterateList f x =  x : iterateList f (f x)
 506         [Not exported]
 507
 508     {-# RULES
 509     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 510     "iterateFB"                 iterateFB (:) = iterateList
 511      #-}
 512
 513 This got shorted out to:
 514
 515     iterateList :: (a -> a) -> a -> [a]
 516     iterateList = iterate
 517
 518     iterateFB c f x = x `c` iterateFB c f (f x)
 519     iterate f x =  x : iterate f (f x)
 520
 521     {-# RULES
 522     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 523     "iterateFB"                 iterateFB (:) = iterate
 524      #-}
 525
 526 And now we get an infinite loop in the rule system
 527         iterate f x -> build (\cn -> iterateFB c f x)
 528                     -> iterateFB (:) f x
 529                     -> iterate f x
 530
 531 Old "solution":
 532         use rule switching-off pragmas to get rid
 533         of iterateList in the first place
 534
 535 But in principle the user *might* want rules that only apply to the Id
 536 he says.  And inline pragmas are similar
 537    {-# NOINLINE f #-}
 538    f = local
 539    local = <stuff>
 540 Then we do not want to get rid of the NOINLINE.
 541
 542 Hence hasShortableIdinfo.
 543
 544
 545 Note [Rules and indirection-zapping]
 546 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 547 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
 548 Then the things mentioned can be out of scope!  Solution
 549  a) Make sure that in this pass the usage-info from x_exported is
 550         available for ...bindings...
 551  b) If there are any such RULES, rec-ify the entire top-level.
 552     It'll get sorted out next time round
 553
 554 Other remarks
 555 ~~~~~~~~~~~~~
 556 If more than one exported thing is equal to a local thing (i.e., the
 557 local thing really is shared), then we do one only:
 558 \begin{verbatim}
 559         x_local = ....
 560         x_exported1 = x_local
 561         x_exported2 = x_local
 562 ==>
 563         x_exported1 = ....
 564
 565         x_exported2 = x_exported1
 566 \end{verbatim}
 567
 568 We rely on prior eta reduction to simplify things like
 569 \begin{verbatim}
 570         x_exported = /\ tyvars -> x_local tyvars
 571 ==>
 572         x_exported = x_local
 573 \end{verbatim}
 574 Hence,there's a possibility of leaving unchanged something like this:
 575 \begin{verbatim}
 576         x_local = ....
 577         x_exported1 = x_local Int
 578 \end{verbatim}
 579 By the time we've thrown away the types in STG land this
 580 could be eliminated.  But I don't think it's very common
 581 and it's dangerous to do this fiddling in STG land
 582 because we might elminate a binding that's mentioned in the
 583 unfolding for something.
 584
 585 \begin{code}
 586 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
 587
 588 shortOutIndirections :: [CoreBind] -> [CoreBind]
 589 shortOutIndirections binds
 590   | isEmptyVarEnv ind_env = binds
 591   | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
 592   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
 593   where
 594     ind_env            = makeIndEnv binds
 595     exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
 596     exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
 597     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
 598     binds'             = concatMap zap binds
 599
 600     zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
 601     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 602
 603     zapPair (bndr, rhs)
 604         | bndr `elemVarSet` exp_id_set             = []
 605         | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
 606                                                       (bndr, Var exp_id)]
 607         | otherwise                                = [(bndr,rhs)]
 608
 609 makeIndEnv :: [CoreBind] -> IndEnv
 610 makeIndEnv binds
 611   = foldr add_bind emptyVarEnv binds
 612   where
 613     add_bind :: CoreBind -> IndEnv -> IndEnv
 614     add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
 615     add_bind (Rec pairs)              env = foldr add_pair env pairs
 616
 617     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
 618     add_pair (exported_id, Var local_id) env
 619         | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
 620     add_pair (exported_id, rhs) env
 621         = env
 622
 623 -----------------
 624 shortMeOut ind_env exported_id local_id
 625 -- The if-then-else stuff is just so I can get a pprTrace to see
 626 -- how often I don't get shorting out becuase of IdInfo stuff
 627   = if isExportedId exported_id &&              -- Only if this is exported
 628
 629        isLocalId local_id &&                    -- Only if this one is defined in this
 630                                                 --      module, so that we *can* change its
 631                                                 --      binding to be the exported thing!
 632
 633        not (isExportedId local_id) &&           -- Only if this one is not itself exported,
 634                                                 --      since the transformation will nuke it
 635
 636        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
 637     then
 638         if hasShortableIdInfo exported_id
 639         then True       -- See Note [Messing up the exported Id's IdInfo]
 640         else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
 641              False
 642     else
 643         False
 644
 645 -----------------
 646 hasShortableIdInfo :: Id -> Bool
 647 -- True if there is no user-attached IdInfo on exported_id,
 648 -- so we can safely discard it
 649 -- See Note [Messing up the exported Id's IdInfo]
 650 hasShortableIdInfo id
 651   =  isEmptySpecInfo (specInfo info)
 652   && isDefaultInlinePragma (inlinePragInfo info)
 653   where
 654      info = idInfo id
 655
 656 -----------------
 657 transferIdInfo :: Id -> Id -> Id
 658 -- See Note [Transferring IdInfo]
 659 -- If we have
 660 --      lcl_id = e; exp_id = lcl_id
 661 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 662 --      gbl_id = e; lcl_id = gbl_id
 663 -- Instead, transfer IdInfo from lcl_id to exp_id
 664 -- Overwriting, rather than merging, seems to work ok.
 665 transferIdInfo exported_id local_id
 666   = modifyIdInfo transfer exported_id
 667   where
 668     local_info = idInfo local_id
 669     transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
 670                                  `setUnfoldingInfo`     unfoldingInfo local_info
 671                                  `setInlinePragInfo`    inlinePragInfo local_info
 672                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
 673     new_info = setSpecInfoHead (idName exported_id)
 674                                (specInfo local_info)
 675         -- Remember to set the function-name field of the
 676         -- rules as we transfer them from one function to another
 677 \end{code}