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 SimplEnv
  35 import SimplMonad
  36 import CoreMonad
  37 import qualified ErrUtils as Err
  38 import CoreLint
  39 import CoreMonad        ( endPass )
  40 import FloatIn          ( floatInwards )
  41 import FloatOut         ( floatOutwards )
  42 import FamInstEnv
  43 import Id
  44 import DataCon
  45 import TyCon            ( tyConDataCons )
  46 import Class            ( classSelIds )
  47 import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )
  48 import VarSet
  49 import VarEnv
  50 import NameEnv          ( lookupNameEnv )
  51 import LiberateCase     ( liberateCase )
  52 import SAT              ( doStaticArgs )
  53 import Specialise       ( specProgram)
  54 import SpecConstr       ( specConstrProgram)
  55 import DmdAnal          ( dmdAnalPgm )
  56 import WorkWrap         ( wwTopBinds )
  57 #ifdef OLD_STRICTNESS
  58 import StrictAnal       ( saBinds )
  59 import CprAnalyse       ( cprAnalyse )
  60 #endif
  61 import Vectorise        ( vectorise )
  62 import FastString
  63 import Util
  64
  65 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  66 import Outputable
  67 import Control.Monad
  68 import Data.List
  69 import System.IO
  70 import Maybes
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{The driver for the simplifier}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 core2core :: HscEnv
  81           -> ModGuts
  82           -> IO ModGuts
  83
  84 core2core hsc_env guts = do
  85     let dflags = hsc_dflags hsc_env
  86
  87     us <- mkSplitUniqSupply 's'
  88     let (cp_us, ru_us) = splitUniqSupply us
  89
  90     -- COMPUTE THE ANNOTATIONS TO USE
  91     ann_env <- prepareAnnotations hsc_env (Just guts)
  92
  93     -- COMPUTE THE RULE BASE TO USE
  94     (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
  95
  96     -- Get the module out of the current HscEnv so we can retrieve it from the monad.
  97     -- This is very convienent for the users of the monad (e.g. plugins do not have to
  98     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
  99     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
 100     -- would mean our cached value would go out of date.
 101     let mod = mg_module guts
 102     (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do
 103         -- FIND BUILT-IN PASSES
 104         let builtin_core_todos = getCoreToDo dflags
 105
 106         -- DO THE BUSINESS
 107         doCorePasses builtin_core_todos guts1
 108
 109     Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
 110         "Grand total simplifier statistics"
 111         (pprSimplCount stats)
 112
 113     return guts2
 114
 115
 116 type CorePass = CoreToDo
 117
 118 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 119              -> CoreExpr
 120              -> IO CoreExpr
 121 -- simplifyExpr is called by the driver to simplify an
 122 -- expression typed in at the interactive prompt
 123 simplifyExpr dflags expr
 124   = do  {
 125         ; Err.showPass dflags "Simplify"
 126
 127         ; us <-  mkSplitUniqSupply 's'
 128
 129         ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 130                                  simplExprGently gentleSimplEnv expr
 131
 132         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 133                         (pprCoreExpr expr')
 134
 135         ; return expr'
 136         }
 137
 138 gentleSimplEnv :: SimplEnv
 139 gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
 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 gentleSimplEnv 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 env rule@(BuiltinRule {})
 413   = return rule
 414 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
 415   = do (env, bndrs') <- simplBinders env bndrs
 416        args' <- mapM (simplExprGently env) args
 417        rhs' <- simplExprGently env rhs
 418        return (rule { ru_bndrs = bndrs', ru_args = args'
 419                     , ru_rhs = occurAnalyseExpr rhs' })
 420 \end{code}
 421
 422 \begin{code}
 423 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 424 -- Simplifies an expression
 425 --      does occurrence analysis, then simplification
 426 --      and repeats (twice currently) because one pass
 427 --      alone leaves tons of crud.
 428 -- Used (a) for user expressions typed in at the interactive prompt
 429 --      (b) the LHS and RHS of a RULE
 430 --      (c) Template Haskell splices
 431 --
 432 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 433 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 434 -- enforce that; it just simplifies the expression twice
 435
 436 -- It's important that simplExprGently does eta reduction; see
 437 -- Note [Simplifying the left-hand side of a RULE] above.  The
 438 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
 439 -- but only if -O is on.
 440
 441 simplExprGently env expr = do
 442     expr1 <- simplExpr env (occurAnalyseExpr expr)
 443     simplExpr env (occurAnalyseExpr expr1)
 444 \end{code}
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Glomming}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 455 -- Glom all binds together in one Rec, in case any
 456 -- transformations have introduced any new dependencies
 457 --
 458 -- NB: the global invariant is this:
 459 --      *** the top level bindings are never cloned, and are always unique ***
 460 --
 461 -- We sort them into dependency order, but applying transformation rules may
 462 -- make something at the top refer to something at the bottom:
 463 --      f = \x -> p (q x)
 464 --      h = \y -> 3
 465 --
 466 --      RULE:  p (q x) = h x
 467 --
 468 -- Applying this rule makes f refer to h,
 469 -- although it doesn't appear to in the source program.
 470 -- This pass lets us control where it happens.
 471 --
 472 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 473 -- function.  It only happens for rules whose head is an imported function
 474 -- (p in the example above).  So, for example, the rule had been
 475 --      RULE: f (p x) = h x
 476 -- then the rule for f would be attached to f itself (in its IdInfo)
 477 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 478 -- analyser as free in f.
 479
 480 glomBinds dflags binds
 481   = do { Err.showPass dflags "GlomBinds" ;
 482          let { recd_binds = [Rec (flattenBinds binds)] } ;
 483          return recd_binds }
 484         -- Not much point in printing the result...
 485         -- just consumes output bandwidth
 486 \end{code}
 487
 488
 489 %************************************************************************
 490 %*                                                                      *
 491 \subsection{The driver for the simplifier}
 492 %*                                                                      *
 493 %************************************************************************
 494
 495 \begin{code}
 496 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
 497 simplifyPgm mode switches
 498   = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
 499     do { hsc_env <- getHscEnv
 500        ; us <- getUniqueSupplyM
 501        ; rb <- getRuleBase
 502        ; liftIOWithCount $
 503          simplifyPgmIO mode switches hsc_env us rb guts }
 504   where
 505     doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
 506
 507 simplifyPgmIO :: SimplifierMode
 508               -> [SimplifierSwitch]
 509               -> HscEnv
 510               -> UniqSupply
 511               -> RuleBase
 512               -> ModGuts
 513               -> IO (SimplCount, ModGuts)  -- New bindings
 514
 515 simplifyPgmIO mode switches hsc_env us hpt_rule_base
 516               guts@(ModGuts { mg_binds = binds, mg_rules = rules
 517                             , mg_fam_inst_env = fam_inst_env })
 518   = do {
 519         (termination_msg, it_count, counts_out, guts')
 520            <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
 521
 522         Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
 523                   "Simplifier statistics for following pass"
 524                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 525                          blankLine,
 526                          pprSimplCount counts_out]);
 527
 528         return (counts_out, guts')
 529     }
 530   where
 531     dflags       = hsc_dflags hsc_env
 532     dump_phase   = shouldDumpSimplPhase dflags mode
 533
 534     sw_chkr        = isAmongSimpl switches
 535     max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 536
 537     do_iteration :: UniqSupply
 538                  -> Int         -- Counts iterations
 539                  -> SimplCount  -- Logs optimisations performed
 540                  -> [CoreBind]  -- Bindings in
 541                  -> [CoreRule]  -- and orphan rules
 542                  -> IO (String, Int, SimplCount, ModGuts)
 543
 544     do_iteration us iteration_no counts binds rules
 545         -- iteration_no is the number of the iteration we are
 546         -- about to begin, with '1' for the first
 547       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 548       =  WARN(debugIsOn && (max_iterations > 2),
 549                 text ("Simplifier still going after " ++
 550                                 show max_iterations ++
 551                                 " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
 552                 -- Subtract 1 from iteration_no to get the
 553                 -- number of iterations we actually completed
 554             return ("Simplifier bailed out", iteration_no - 1, counts,
 555                     guts { mg_binds = binds, mg_rules = rules })
 556
 557       -- Try and force thunks off the binds; significantly reduces
 558       -- space usage, especially with -O.  JRS, 000620.
 559       | let sz = coreBindsSize binds in sz == sz
 560       = do {
 561                 -- Occurrence analysis
 562            let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
 563            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 564                      (pprCoreBindings tagged_binds);
 565
 566                 -- Get any new rules, and extend the rule base
 567                 -- We need to do this regularly, because simplification can
 568                 -- poke on IdInfo thunks, which in turn brings in new rules
 569                 -- behind the scenes.  Otherwise there's a danger we'll simply
 570                 -- miss the rules for Ids hidden inside imported inlinings
 571            eps <- hscEPS hsc_env ;
 572            let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
 573                 ; rule_base2 = extendRuleBaseList rule_base1 rules
 574                 ; simpl_env  = mkSimplEnv mode sw_chkr
 575                 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
 576                                 simplTopBinds simpl_env tagged_binds
 577                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
 578
 579                 -- Simplify the program
 580                 -- We do this with a *case* not a *let* because lazy pattern
 581                 -- matching bit us with bad space leak!
 582                 -- With a let, we ended up with
 583                 --   let
 584                 --      t = initSmpl ...
 585                 --      counts' = snd t
 586                 --   in
 587                 --      case t of {(_,counts') -> if counts'=0 then ... }
 588                 -- So the conditional didn't force counts', because the
 589                 -- selection got duplicated.  Sigh!
 590            case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
 591                 (env1, counts1) -> do {
 592
 593            let  { all_counts = counts `plusSimplCount` counts1
 594                 ; binds1 = getFloats env1
 595                 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
 596                 } ;
 597
 598                 -- Stop if nothing happened; don't dump output
 599            if isZeroSimplCount counts1 then
 600                 return ("Simplifier reached fixed point", iteration_no, all_counts,
 601                         guts { mg_binds = binds1, mg_rules = rules1 })
 602            else do {
 603                 -- Short out indirections
 604                 -- We do this *after* at least one run of the simplifier
 605                 -- because indirection-shorting uses the export flag on *occurrences*
 606                 -- and that isn't guaranteed to be ok until after the first run propagates
 607                 -- stuff from the binding site to its occurrences
 608                 --
 609                 -- ToDo: alas, this means that indirection-shorting does not happen at all
 610                 --       if the simplifier does nothing (not common, I know, but unsavoury)
 611            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 612
 613                 -- Dump the result of this iteration
 614            end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
 615
 616                 -- Loop
 617            do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
 618         }  } } }
 619       where
 620           (us1, us2) = splitUniqSupply us
 621
 622 -------------------
 623 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
 624              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 625 -- Same as endIteration but with simplifier counts
 626 end_iteration dflags mode iteration_no max_iterations counts binds rules
 627   = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
 628                              (pprSimplCount counts) ;
 629
 630        ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
 631   where
 632     pass_name = "Simplifier mode " ++ showPpr mode ++
 633                 ", iteration " ++ show iteration_no ++
 634                 " out of " ++ show max_iterations
 635 \end{code}
 636
 637
 638 %************************************************************************
 639 %*                                                                      *
 640                 Shorting out indirections
 641 %*                                                                      *
 642 %************************************************************************
 643
 644 If we have this:
 645
 646         x_local = <expression>
 647         ...bindings...
 648         x_exported = x_local
 649
 650 where x_exported is exported, and x_local is not, then we replace it with this:
 651
 652         x_exported = <expression>
 653         x_local = x_exported
 654         ...bindings...
 655
 656 Without this we never get rid of the x_exported = x_local thing.  This
 657 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 658 makes strictness information propagate better.  This used to happen in
 659 the final phase, but it's tidier to do it here.
 660
 661 Note [Transferring IdInfo]
 662 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 663 We want to propagage any useful IdInfo on x_local to x_exported.
 664
 665 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 666 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 667
 668 RULES: we want to *add* any RULES for x_local to x_exported.
 669
 670
 671 Note [Messing up the exported Id's RULES]
 672 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 673 We must be careful about discarding (obviously) or even merging the
 674 RULES on the exported Id. The example that went bad on me at one stage
 675 was this one:
 676
 677     iterate :: (a -> a) -> a -> [a]
 678         [Exported]
 679     iterate = iterateList
 680
 681     iterateFB c f x = x `c` iterateFB c f (f x)
 682     iterateList f x =  x : iterateList f (f x)
 683         [Not exported]
 684
 685     {-# RULES
 686     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 687     "iterateFB"                 iterateFB (:) = iterateList
 688      #-}
 689
 690 This got shorted out to:
 691
 692     iterateList :: (a -> a) -> a -> [a]
 693     iterateList = iterate
 694
 695     iterateFB c f x = x `c` iterateFB c f (f x)
 696     iterate f x =  x : iterate f (f x)
 697
 698     {-# RULES
 699     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
 700     "iterateFB"                 iterateFB (:) = iterate
 701      #-}
 702
 703 And now we get an infinite loop in the rule system
 704         iterate f x -> build (\cn -> iterateFB c f x)
 705                     -> iterateFB (:) f x
 706                     -> iterate f x
 707
 708 Old "solution":
 709         use rule switching-off pragmas to get rid
 710         of iterateList in the first place
 711
 712 But in principle the user *might* want rules that only apply to the Id
 713 he says.  And inline pragmas are similar
 714    {-# NOINLINE f #-}
 715    f = local
 716    local = <stuff>
 717 Then we do not want to get rid of the NOINLINE.
 718
 719 Hence hasShortableIdinfo.
 720
 721
 722 Note [Rules and indirection-zapping]
 723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 724 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
 725 Then the things mentioned can be out of scope!  Solution
 726  a) Make sure that in this pass the usage-info from x_exported is
 727         available for ...bindings...
 728  b) If there are any such RULES, rec-ify the entire top-level.
 729     It'll get sorted out next time round
 730
 731 Other remarks
 732 ~~~~~~~~~~~~~
 733 If more than one exported thing is equal to a local thing (i.e., the
 734 local thing really is shared), then we do one only:
 735 \begin{verbatim}
 736         x_local = ....
 737         x_exported1 = x_local
 738         x_exported2 = x_local
 739 ==>
 740         x_exported1 = ....
 741
 742         x_exported2 = x_exported1
 743 \end{verbatim}
 744
 745 We rely on prior eta reduction to simplify things like
 746 \begin{verbatim}
 747         x_exported = /\ tyvars -> x_local tyvars
 748 ==>
 749         x_exported = x_local
 750 \end{verbatim}
 751 Hence,there's a possibility of leaving unchanged something like this:
 752 \begin{verbatim}
 753         x_local = ....
 754         x_exported1 = x_local Int
 755 \end{verbatim}
 756 By the time we've thrown away the types in STG land this
 757 could be eliminated.  But I don't think it's very common
 758 and it's dangerous to do this fiddling in STG land
 759 because we might elminate a binding that's mentioned in the
 760 unfolding for something.
 761
 762 \begin{code}
 763 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
 764
 765 shortOutIndirections :: [CoreBind] -> [CoreBind]
 766 shortOutIndirections binds
 767   | isEmptyVarEnv ind_env = binds
 768   | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
 769   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
 770   where
 771     ind_env            = makeIndEnv binds
 772     exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
 773     exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
 774     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
 775     binds'             = concatMap zap binds
 776
 777     zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
 778     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 779
 780     zapPair (bndr, rhs)
 781         | bndr `elemVarSet` exp_id_set             = []
 782         | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
 783                                                       (bndr, Var exp_id)]
 784         | otherwise                                = [(bndr,rhs)]
 785
 786 makeIndEnv :: [CoreBind] -> IndEnv
 787 makeIndEnv binds
 788   = foldr add_bind emptyVarEnv binds
 789   where
 790     add_bind :: CoreBind -> IndEnv -> IndEnv
 791     add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
 792     add_bind (Rec pairs)              env = foldr add_pair env pairs
 793
 794     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
 795     add_pair (exported_id, Var local_id) env
 796         | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
 797     add_pair (exported_id, rhs) env
 798         = env
 799
 800 -----------------
 801 shortMeOut ind_env exported_id local_id
 802 -- The if-then-else stuff is just so I can get a pprTrace to see
 803 -- how often I don't get shorting out becuase of IdInfo stuff
 804   = if isExportedId exported_id &&              -- Only if this is exported
 805
 806        isLocalId local_id &&                    -- Only if this one is defined in this
 807                                                 --      module, so that we *can* change its
 808                                                 --      binding to be the exported thing!
 809
 810        not (isExportedId local_id) &&           -- Only if this one is not itself exported,
 811                                                 --      since the transformation will nuke it
 812
 813        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
 814     then
 815         if hasShortableIdInfo exported_id
 816         then True       -- See Note [Messing up the exported Id's IdInfo]
 817         else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
 818              False
 819     else
 820         False
 821
 822 -----------------
 823 hasShortableIdInfo :: Id -> Bool
 824 -- True if there is no user-attached IdInfo on exported_id,
 825 -- so we can safely discard it
 826 -- See Note [Messing up the exported Id's IdInfo]
 827 hasShortableIdInfo id
 828   =  isEmptySpecInfo (specInfo info)
 829   && isDefaultInlinePragma (inlinePragInfo info)
 830   where
 831      info = idInfo id
 832
 833 -----------------
 834 transferIdInfo :: Id -> Id -> Id
 835 -- See Note [Transferring IdInfo]
 836 -- If we have
 837 --      lcl_id = e; exp_id = lcl_id
 838 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 839 --      gbl_id = e; lcl_id = gbl_id
 840 -- Instead, transfer IdInfo from lcl_id to exp_id
 841 -- Overwriting, rather than merging, seems to work ok.
 842 transferIdInfo exported_id local_id
 843   = modifyIdInfo transfer exported_id
 844   where
 845     local_info = idInfo local_id
 846     transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
 847                                  `setUnfoldingInfo`     unfoldingInfo local_info
 848                                  `setInlinePragInfo`    inlinePragInfo local_info
 849                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
 850     new_info = setSpecInfoHead (idName exported_id)
 851                                (specInfo local_info)
 852         -- Remember to set the function-name field of the
 853         -- rules as we transfer them from one function to another
 854 \end{code}