compiler/simplCore/SimplCore.lhs

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