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