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