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