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