compiler/simplCore/SimplCore.lhs

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