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 IdInfo]
 672 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 673 We must be careful about discarding the IdInfo on the old Id
 674
 675 The example that went bad on me at one stage 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}