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