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