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