compiler/simplCore/SimplCore.lhs

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