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(..), hscEPS )
  19 import CSE              ( cseProgram )
  20 import Rules            ( RuleBase, ruleBaseIds, emptyRuleBase,
  21                           extendRuleBaseList, pprRuleBase, ruleCheckProgram )
  22 import Module           ( moduleEnvElts )
  23 import PprCore          ( pprCoreBindings, pprCoreExpr, pprIdRules )
  24 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  25 import CoreUtils        ( coreBindsSize )
  26 import Simplify         ( simplTopBinds, simplExpr )
  27 import SimplEnv         ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
  28 import SimplMonad
  29 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  30 import CoreLint         ( endPass )
  31 import VarEnv           ( mkInScopeSet )
  32 import FloatIn          ( floatInwards )
  33 import FloatOut         ( floatOutwards )
  34 import Id               ( idIsFrom, idSpecialisation, setIdSpecialisation )
  35 import VarSet
  36 import LiberateCase     ( liberateCase )
  37 import SAT              ( doStaticArgs )
  38 import Specialise       ( specProgram)
  39 import SpecConstr       ( specConstrProgram)
  40 import DmdAnal          ( dmdAnalPgm )
  41 import WorkWrap         ( wwTopBinds )
  42 #ifdef OLD_STRICTNESS
  43 import StrictAnal       ( saBinds )
  44 import CprAnalyse       ( cprAnalyse )
  45 #endif
  46
  47 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  48 import IO               ( hPutStr, stderr )
  49 import Outputable
  50 import List             ( partition )
  51 import Maybes           ( orElse )
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{The driver for the simplifier}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 core2core :: HscEnv
  62           -> ModGuts
  63           -> IO ModGuts
  64
  65 core2core hsc_env guts
  66   = do
  67         let dflags = hsc_dflags hsc_env
  68             core_todos
  69                 | Just todo <- dopt_CoreToDo dflags  =  todo
  70                 | otherwise                          =  buildCoreToDo dflags
  71
  72         us <- mkSplitUniqSupply 's'
  73         let (cp_us, ru_us) = splitUniqSupply us
  74
  75                 -- COMPUTE THE RULE BASE TO USE
  76         (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
  77
  78                 -- DO THE BUSINESS
  79         (stats, guts'') <- doCorePasses hsc_env cp_us
  80                                         (zeroSimplCount dflags)
  81                                         imp_rule_base guts' core_todos
  82
  83         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  84                   "Grand total simplifier statistics"
  85                   (pprSimplCount stats)
  86
  87         return guts''
  88
  89
  90 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
  91              -> CoreExpr
  92              -> IO CoreExpr
  93 -- simplifyExpr is called by the driver to simplify an
  94 -- expression typed in at the interactive prompt
  95 simplifyExpr dflags expr
  96   = do  {
  97         ; showPass dflags "Simplify"
  98
  99         ; us <-  mkSplitUniqSupply 's'
 100
 101         ; let (expr', _counts) = initSmpl dflags us $
 102                                  simplExprGently gentleSimplEnv expr
 103
 104         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 105                         (pprCoreExpr expr')
 106
 107         ; return expr'
 108         }
 109
 110 gentleSimplEnv :: SimplEnv
 111 gentleSimplEnv = mkSimplEnv SimplGently
 112                             (isAmongSimpl [])
 113                             emptyRuleBase
 114
 115 doCorePasses :: HscEnv
 116              -> UniqSupply      -- uniques
 117              -> SimplCount      -- simplifier stats
 118              -> RuleBase        -- the main rule base
 119              -> ModGuts         -- local binds in (with rules attached)
 120              -> [CoreToDo]      -- which passes to do
 121              -> IO (SimplCount, ModGuts)
 122
 123 doCorePasses hsc_env us stats rb guts []
 124   = return (stats, guts)
 125
 126 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
 127   = do
 128         let (us1, us2) = splitUniqSupply us
 129         (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
 130         doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
 131
 132 doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
 133 doCorePass CoreCSE                     = _scc_ "CommonSubExpr" trBinds  cseProgram
 134 doCorePass CoreLiberateCase            = _scc_ "LiberateCase"  trBinds  liberateCase
 135 doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
 136 doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
 137 doCorePass CoreDoStaticArgs            = _scc_ "StaticArgs"    trBinds  doStaticArgs
 138 doCorePass CoreDoStrictness            = _scc_ "Stranal"       trBinds  dmdAnalPgm
 139 doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
 140 doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
 141 doCorePass CoreDoSpecConstr            = _scc_ "SpecConstr"    trBindsU specConstrProgram
 142 doCorePass CoreDoGlomBinds             = trBinds glomBinds
 143 doCorePass CoreDoPrintCore             = observe printCore
 144 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
 145 doCorePass CoreDoNothing               = observe (\ _ _ -> return ())
 146 #ifdef OLD_STRICTNESS
 147 doCorePass CoreDoOldStrictness         = _scc_ "OldStrictness" trBinds doOldStrictness
 148 #endif
 149
 150 #ifdef OLD_STRICTNESS
 151 doOldStrictness dfs binds
 152   = do binds1 <- saBinds dfs binds
 153        binds2 <- cprAnalyse dfs binds1
 154        return binds2
 155 #endif
 156
 157 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 158
 159 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
 160                                       printDump (ruleCheckProgram phase pat binds)
 161
 162 -- Most passes return no stats and don't change rules
 163 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 164         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 165         -> IO (SimplCount, RuleBase, ModGuts)
 166 trBinds do_pass hsc_env us rb guts
 167   = do  { binds' <- do_pass dflags (mg_binds guts)
 168         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 169   where
 170     dflags = hsc_dflags hsc_env
 171
 172 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
 173         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 174         -> IO (SimplCount, RuleBase, ModGuts)
 175 trBindsU do_pass hsc_env us rb guts
 176   = do  { binds' <- do_pass dflags us (mg_binds guts)
 177         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 178   where
 179     dflags = hsc_dflags hsc_env
 180
 181 -- Observer passes just peek; don't modify the bindings at all
 182 observe :: (DynFlags -> [CoreBind] -> IO a)
 183         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 184         -> IO (SimplCount, RuleBase, ModGuts)
 185 observe do_pass hsc_env us rb guts
 186   = do  { binds <- do_pass dflags (mg_binds guts)
 187         ; return (zeroSimplCount dflags, rb, guts) }
 188   where
 189     dflags = hsc_dflags hsc_env
 190 \end{code}
 191
 192
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection{Dealing with rules}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 201 -- It attaches those rules that are for local Ids to their binders, and
 202 -- returns the remainder attached to Ids in an IdSet.
 203
 204 \begin{code}
 205 prepareRules :: HscEnv
 206              -> ModGuts
 207              -> UniqSupply
 208              -> IO (RuleBase,           -- Rule base for imported things, incl
 209                                         -- (a) rules defined in this module (orphans)
 210                                         -- (b) rules from other packages
 211                                         -- (c) rules from other modules in home package
 212                     ModGuts)            -- Modified fields are
 213                                         --      (a) Bindings have rules attached,
 214                                         --      (b) Rules are now just orphan rules
 215
 216 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 217              guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
 218              us
 219   = do  { eps <- hscEPS hsc_env
 220
 221         ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
 222                 -- from the local binders, to avoid warnings from Simplify.simplVar
 223               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 224               env              = setInScopeSet gentleSimplEnv local_ids
 225               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 226
 227               (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
 228                 -- Get the rules for locally-defined Ids out of the RuleBase
 229                 -- If we miss any rules for Ids defined here, then we end up
 230                 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
 231                 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
 232                 -- and hence should be cloned), and now the binding for the class method
 233                 -- doesn't have the same Unique as the one in the Class and the tc-env
 234                 --      Example:        class Foo a where
 235                 --                        op :: a -> a
 236                 --                      {-# RULES "op" op x = x #-}
 237
 238                 -- NB: we assume that the imported rules dont include
 239                 --     rules for Ids in this module; if there is, the above bad things may happen
 240
 241               pkg_rule_base = eps_rule_base eps
 242               hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
 243               imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
 244
 245                 -- Update the binders in the local bindings with the lcoal rules
 246                 -- Update the binders of top-level bindings by
 247                 -- attaching the rules for each locally-defined Id to that Id.
 248                 --
 249                 -- Reason
 250                 --      - It makes the rules easier to look up
 251                 --      - It means that transformation rules and specialisations for
 252                 --        locally defined Ids are handled uniformly
 253                 --      - It keeps alive things that are referred to only from a rule
 254                 --        (the occurrence analyser knows about rules attached to Ids)
 255                 --      - It makes sure that, when we apply a rule, the free vars
 256                 --        of the RHS are more likely to be in scope
 257                 --      - The imported rules are carried in the in-scope set
 258                 --        which is extended on each iteration by the new wave of
 259                 --        local binders; any rules which aren't on the binding will
 260                 --        thereby get dropped
 261               local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
 262               binds_w_rules   = updateBinders local_rule_base binds
 263
 264         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 265                 (vcat [text "Local rules", pprIdRules better_rules,
 266                        text "",
 267                        text "Imported rules", pprRuleBase imp_rule_base])
 268
 269 #ifdef DEBUG
 270         ; let bad_rules = filter (idIsFrom (mg_module guts))
 271                                  (varSetElems (ruleBaseIds imp_rule_base))
 272         ; WARN( not (null bad_rules), ppr bad_rules ) return ()
 273 #endif
 274         ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
 275     }
 276   where
 277     add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
 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 (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}