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