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