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