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