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