ghc/compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[SimplCore]{Driver for simplifying @Core@ programs}
   5
   6 \begin{code}
   7 module SimplCore ( core2core, simplifyExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..),
  12                           SimplifierMode(..), DynFlags, DynFlag(..), dopt,
  13                           dopt_CoreToDo, buildCoreToDo
  14                         )
  15 import CoreSyn
  16 import TcIface          ( loadImportedRules )
  17 import HscTypes         ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
  18                           ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ),
  19                           hscEPS, hptRules )
  20 import CSE              ( cseProgram )
  21 import Rules            ( RuleBase, ruleBaseIds, emptyRuleBase,
  22                           extendRuleBaseList, pprRuleBase, ruleCheckProgram )
  23 import Module           ( elemModuleEnv, lookupModuleEnv )
  24 import PprCore          ( pprCoreBindings, pprCoreExpr, pprIdRules )
  25 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  26 import CoreUtils        ( coreBindsSize )
  27 import Simplify         ( simplTopBinds, simplExpr )
  28 import SimplEnv         ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
  29 import SimplMonad
  30 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  31 import CoreLint         ( endPass )
  32 import VarEnv           ( mkInScopeSet )
  33 import FloatIn          ( floatInwards )
  34 import FloatOut         ( floatOutwards )
  35 import Id               ( idIsFrom, idSpecialisation, setIdSpecialisation )
  36 import VarSet
  37 import LiberateCase     ( liberateCase )
  38 import SAT              ( doStaticArgs )
  39 import Specialise       ( specProgram)
  40 import SpecConstr       ( specConstrProgram)
  41 import DmdAnal          ( dmdAnalPgm )
  42 import WorkWrap         ( wwTopBinds )
  43 #ifdef OLD_STRICTNESS
  44 import StrictAnal       ( saBinds )
  45 import CprAnalyse       ( cprAnalyse )
  46 #endif
  47
  48 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  49 import IO               ( hPutStr, stderr )
  50 import Outputable
  51 import List             ( partition )
  52 import Maybes           ( orElse, fromJust )
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{The driver for the simplifier}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 core2core :: HscEnv
  63           -> ModGuts
  64           -> IO ModGuts
  65
  66 core2core hsc_env guts
  67   = do
  68         let dflags = hsc_dflags hsc_env
  69             core_todos
  70                 | Just todo <- dopt_CoreToDo dflags  =  todo
  71                 | otherwise                          =  buildCoreToDo dflags
  72
  73         us <- mkSplitUniqSupply 's'
  74         let (cp_us, ru_us) = splitUniqSupply us
  75
  76                 -- COMPUTE THE RULE BASE TO USE
  77         (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
  78
  79                 -- DO THE BUSINESS
  80         (stats, guts'') <- doCorePasses hsc_env cp_us
  81                                         (zeroSimplCount dflags)
  82                                         imp_rule_base guts' core_todos
  83
  84         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  85                   "Grand total simplifier statistics"
  86                   (pprSimplCount stats)
  87
  88         return guts''
  89
  90
  91 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
  92              -> CoreExpr
  93              -> IO CoreExpr
  94 -- simplifyExpr is called by the driver to simplify an
  95 -- expression typed in at the interactive prompt
  96 simplifyExpr dflags expr
  97   = do  {
  98         ; showPass dflags "Simplify"
  99
 100         ; us <-  mkSplitUniqSupply 's'
 101
 102         ; let (expr', _counts) = initSmpl dflags us $
 103                                  simplExprGently gentleSimplEnv expr
 104
 105         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 106                         (pprCoreExpr expr')
 107
 108         ; return expr'
 109         }
 110
 111 gentleSimplEnv :: SimplEnv
 112 gentleSimplEnv = mkSimplEnv SimplGently
 113                             (isAmongSimpl [])
 114                             emptyRuleBase
 115
 116 doCorePasses :: HscEnv
 117              -> UniqSupply      -- uniques
 118              -> SimplCount      -- simplifier stats
 119              -> RuleBase        -- the main rule base
 120              -> ModGuts         -- local binds in (with rules attached)
 121              -> [CoreToDo]      -- which passes to do
 122              -> IO (SimplCount, ModGuts)
 123
 124 doCorePasses hsc_env us stats rb guts []
 125   = return (stats, guts)
 126
 127 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
 128   = do
 129         let (us1, us2) = splitUniqSupply us
 130         (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
 131         doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
 132
 133 doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
 134 doCorePass CoreCSE                     = _scc_ "CommonSubExpr" trBinds  cseProgram
 135 doCorePass CoreLiberateCase            = _scc_ "LiberateCase"  trBinds  liberateCase
 136 doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
 137 doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
 138 doCorePass CoreDoStaticArgs            = _scc_ "StaticArgs"    trBinds  doStaticArgs
 139 doCorePass CoreDoStrictness            = _scc_ "Stranal"       trBinds  dmdAnalPgm
 140 doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
 141 doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
 142 doCorePass CoreDoSpecConstr            = _scc_ "SpecConstr"    trBindsU specConstrProgram
 143 doCorePass CoreDoGlomBinds             = trBinds glomBinds
 144 doCorePass CoreDoPrintCore             = observe printCore
 145 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
 146 doCorePass CoreDoNothing               = observe (\ _ _ -> return ())
 147 #ifdef OLD_STRICTNESS
 148 doCorePass CoreDoOldStrictness         = _scc_ "OldStrictness" trBinds doOldStrictness
 149 #endif
 150
 151 #ifdef OLD_STRICTNESS
 152 doOldStrictness dfs binds
 153   = do binds1 <- saBinds dfs binds
 154        binds2 <- cprAnalyse dfs binds1
 155        return binds2
 156 #endif
 157
 158 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 159
 160 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
 161                                       printDump (ruleCheckProgram phase pat binds)
 162
 163 -- Most passes return no stats and don't change rules
 164 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 165         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 166         -> IO (SimplCount, RuleBase, ModGuts)
 167 trBinds do_pass hsc_env us rb guts
 168   = do  { binds' <- do_pass dflags (mg_binds guts)
 169         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 170   where
 171     dflags = hsc_dflags hsc_env
 172
 173 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
 174         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 175         -> IO (SimplCount, RuleBase, ModGuts)
 176 trBindsU do_pass hsc_env us rb guts
 177   = do  { binds' <- do_pass dflags us (mg_binds guts)
 178         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 179   where
 180     dflags = hsc_dflags hsc_env
 181
 182 -- Observer passes just peek; don't modify the bindings at all
 183 observe :: (DynFlags -> [CoreBind] -> IO a)
 184         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 185         -> IO (SimplCount, RuleBase, ModGuts)
 186 observe do_pass hsc_env us rb guts
 187   = do  { binds <- do_pass dflags (mg_binds guts)
 188         ; return (zeroSimplCount dflags, rb, guts) }
 189   where
 190     dflags = hsc_dflags hsc_env
 191 \end{code}
 192
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Dealing with rules}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 202 -- It attaches those rules that are for local Ids to their binders, and
 203 -- returns the remainder attached to Ids in an IdSet.
 204
 205 \begin{code}
 206 prepareRules :: HscEnv
 207              -> ModGuts
 208              -> UniqSupply
 209              -> IO (RuleBase,           -- Rule base for imported things, incl
 210                                         -- (a) rules defined in this module (orphans)
 211                                         -- (b) rules from other packages
 212                                         -- (c) rules from other modules in home package
 213                     ModGuts)            -- Modified fields are
 214                                         --      (a) Bindings have rules attached,
 215                                         --      (b) Rules are now just orphan rules
 216
 217 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 218              guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
 219              us
 220   = do  { eps <- hscEPS hsc_env
 221
 222         ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
 223                 -- from the local binders, to avoid warnings from Simplify.simplVar
 224               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 225               env              = setInScopeSet gentleSimplEnv local_ids
 226               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 227               home_pkg_rules   = hptRules hsc_env (dep_mods deps)
 228
 229               (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
 230                 -- Get the rules for locally-defined Ids out of the RuleBase
 231                 -- If we miss any rules for Ids defined here, then we end up
 232                 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
 233                 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
 234                 -- and hence should be cloned), and now the binding for the class method
 235                 -- doesn't have the same Unique as the one in the Class and the tc-env
 236                 --      Example:        class Foo a where
 237                 --                        op :: a -> a
 238                 --                      {-# RULES "op" op x = x #-}
 239
 240                 -- NB: we assume that the imported rules dont include
 241                 --     rules for Ids in this module; if there is, the above bad things may happen
 242
 243               pkg_rule_base = eps_rule_base eps
 244               hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules
 245               imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
 246
 247                 -- Update the binders in the local bindings with the lcoal rules
 248                 -- Update the binders of top-level bindings by
 249                 -- attaching the rules for each locally-defined Id to that Id.
 250                 --
 251                 -- Reason
 252                 --      - It makes the rules easier to look up
 253                 --      - It means that transformation rules and specialisations for
 254                 --        locally defined Ids are handled uniformly
 255                 --      - It keeps alive things that are referred to only from a rule
 256                 --        (the occurrence analyser knows about rules attached to Ids)
 257                 --      - It makes sure that, when we apply a rule, the free vars
 258                 --        of the RHS are more likely to be in scope
 259                 --      - The imported rules are carried in the in-scope set
 260                 --        which is extended on each iteration by the new wave of
 261                 --        local binders; any rules which aren't on the binding will
 262                 --        thereby get dropped
 263               local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
 264               binds_w_rules   = updateBinders local_rule_base binds
 265
 266         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 267                 (vcat [text "Local rules", pprIdRules better_rules,
 268                        text "",
 269                        text "Imported rules", pprRuleBase imp_rule_base])
 270
 271 #ifdef DEBUG
 272         ; let bad_rules = filter (idIsFrom (mg_module guts))
 273                                  (varSetElems (ruleBaseIds imp_rule_base))
 274         ; WARN( not (null bad_rules), ppr bad_rules ) return ()
 275 #endif
 276         ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
 277     }
 278
 279 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
 280 updateBinders rule_base binds
 281   = map update_bndrs binds
 282   where
 283     rule_ids = ruleBaseIds rule_base
 284
 285     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 286     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 287
 288     update_bndr bndr = case lookupVarSet rule_ids bndr of
 289                           Nothing -> bndr
 290                           Just id -> bndr `setIdSpecialisation` idSpecialisation id
 291 \end{code}
 292
 293
 294 We must do some gentle simplification on the template (but not the RHS)
 295 of each rule.  The case that forced me to add this was the fold/build rule,
 296 which without simplification looked like:
 297         fold k z (build (/\a. g a))  ==>  ...
 298 This doesn't match unless you do eta reduction on the build argument.
 299
 300 \begin{code}
 301 simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
 302   = returnSmpl rule
 303 simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
 304   = simplBinders env bndrs              `thenSmpl` \ (env, bndrs') ->
 305     mapSmpl (simplExprGently env) args  `thenSmpl` \ args' ->
 306     simplExprGently env rhs             `thenSmpl` \ rhs' ->
 307     returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
 308
 309 -- It's important that simplExprGently does eta reduction.
 310 -- For example, in a rule like:
 311 --      augment g (build h)
 312 -- we do not want to get
 313 --      augment (\a. g a) (build h)
 314 -- otherwise we don't match when given an argument like
 315 --      (\a. h a a)
 316 --
 317 -- The simplifier does indeed do eta reduction (it's in
 318 -- Simplify.completeLam) but only if -O is on.
 319 \end{code}
 320
 321 \begin{code}
 322 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 323 -- Simplifies an expression
 324 --      does occurrence analysis, then simplification
 325 --      and repeats (twice currently) because one pass
 326 --      alone leaves tons of crud.
 327 -- Used (a) for user expressions typed in at the interactive prompt
 328 --      (b) the LHS and RHS of a RULE
 329 --
 330 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 331 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 332 -- enforce that; it just simplifies the expression twice
 333
 334 simplExprGently env expr
 335   = simplExpr env (occurAnalyseGlobalExpr expr)         `thenSmpl` \ expr1 ->
 336     simplExpr env (occurAnalyseGlobalExpr expr1)
 337 \end{code}
 338
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection{Glomming}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 \begin{code}
 347 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 348 -- Glom all binds together in one Rec, in case any
 349 -- transformations have introduced any new dependencies
 350 --
 351 -- NB: the global invariant is this:
 352 --      *** the top level bindings are never cloned, and are always unique ***
 353 --
 354 -- We sort them into dependency order, but applying transformation rules may
 355 -- make something at the top refer to something at the bottom:
 356 --      f = \x -> p (q x)
 357 --      h = \y -> 3
 358 --
 359 --      RULE:  p (q x) = h x
 360 --
 361 -- Applying this rule makes f refer to h,
 362 -- although it doesn't appear to in the source program.
 363 -- This pass lets us control where it happens.
 364 --
 365 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 366 -- function.  It only happens for rules whose head is an imported function
 367 -- (p in the example above).  So, for example, the rule had been
 368 --      RULE: f (p x) = h x
 369 -- then the rule for f would be attached to f itself (in its IdInfo)
 370 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 371 -- analyser as free in f.
 372
 373 glomBinds dflags binds
 374   = do { showPass dflags "GlomBinds" ;
 375          let { recd_binds = [Rec (flattenBinds binds)] } ;
 376          return recd_binds }
 377         -- Not much point in printing the result...
 378         -- just consumes output bandwidth
 379 \end{code}
 380
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection{The driver for the simplifier}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 simplifyPgm :: SimplifierMode
 390             -> [SimplifierSwitch]
 391             -> HscEnv
 392             -> UniqSupply
 393             -> RuleBase
 394             -> ModGuts
 395             -> IO (SimplCount, RuleBase, ModGuts)  -- New bindings
 396
 397 simplifyPgm mode switches hsc_env us rule_base guts
 398   = do {
 399         showPass dflags "Simplify";
 400
 401         (termination_msg, it_count, counts_out, rule_base', guts')
 402            <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
 403
 404         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 405                    && dopt Opt_D_dump_simpl_stats dflags)
 406                   "Simplifier statistics"
 407                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 408                          text "",
 409                          pprSimplCount counts_out]);
 410
 411         endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
 412
 413         return (counts_out, rule_base', guts')
 414     }
 415   where
 416     dflags            = hsc_dflags hsc_env
 417     phase_info        = case mode of
 418                           SimplGently  -> "gentle"
 419                           SimplPhase n -> show n
 420
 421     sw_chkr           = isAmongSimpl switches
 422     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 423
 424     do_iteration us rule_base iteration_no counts guts
 425         -- iteration_no is the number of the iteration we are
 426         -- about to begin, with '1' for the first
 427       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 428       = do {
 429 #ifdef DEBUG
 430             if  max_iterations > 2 then
 431                 hPutStr stderr ("NOTE: Simplifier still going after " ++
 432                                 show max_iterations ++
 433                                 " iterations; bailing out.\n")
 434             else
 435                 return ();
 436 #endif
 437                 -- Subtract 1 from iteration_no to get the
 438                 -- number of iterations we actually completed
 439             return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
 440         }
 441
 442       -- Try and force thunks off the binds; significantly reduces
 443       -- space usage, especially with -O.  JRS, 000620.
 444       | let sz = coreBindsSize (mg_binds guts) in sz == sz
 445       = do {
 446                 -- Occurrence analysis
 447            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
 448
 449            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 450                      (pprCoreBindings tagged_binds);
 451
 452                 -- Get any new rules, and extend the rule base
 453                 -- (on the side this extends the package rule base in the
 454                 --  ExternalPackageTable, ready for the next complation
 455                 --  in --make mode)
 456                 -- We need to do this regularly, because simplification can
 457                 -- poke on IdInfo thunks, which in turn brings in new rules
 458                 -- behind the scenes.  Otherwise there's a danger we'll simply
 459                 -- miss the rules for Ids hidden inside imported inlinings
 460            new_rules <- loadImportedRules hsc_env guts ;
 461            let  { rule_base' = extendRuleBaseList rule_base new_rules
 462                 ; simpl_env  = mkSimplEnv mode sw_chkr rule_base' } ;
 463                         -- The new rule base Ids are used to initialise
 464                         -- the in-scope set.  That way, the simplifier will change any
 465                         -- occurrences of the imported id to the one in the imported_rule_ids
 466                         -- set, which are decorated with their rules.
 467
 468                 -- Simplify the program
 469                 -- We do this with a *case* not a *let* because lazy pattern
 470                 -- matching bit us with bad space leak!
 471                 -- With a let, we ended up with
 472                 --   let
 473                 --      t = initSmpl ...
 474                 --      counts' = snd t
 475                 --   in
 476                 --      case t of {(_,counts') -> if counts'=0 then ... }
 477                 -- So the conditional didn't force counts', because the
 478                 -- selection got duplicated.  Sigh!
 479            case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
 480                 (binds', counts') -> do {
 481
 482            let  { guts'      = guts { mg_binds = binds' }
 483                 ; all_counts = counts `plusSimplCount` counts'
 484                 ; herald     = "Simplifier phase " ++ phase_info ++
 485                               ", iteration " ++ show iteration_no ++
 486                               " out of " ++ show max_iterations
 487                 } ;
 488
 489                 -- Stop if nothing happened; don't dump output
 490            if isZeroSimplCount counts' then
 491                 return ("Simplifier reached fixed point", iteration_no,
 492                         all_counts, rule_base', guts')
 493            else do {
 494
 495                 -- Dump the result of this iteration
 496            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 497                          (pprSimplCount counts') ;
 498
 499            endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 500
 501                 -- Loop
 502            do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
 503         }  } } }
 504       where
 505           (us1, us2) = splitUniqSupply us
 506 \end{code}