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