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