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
  14                         )
  15 import CoreSyn
  16 import CoreFVs          ( ruleRhsFreeVars )
  17 import HscTypes         ( PersistentCompilerState(..), ExternalPackageState(..),
  18                           HscEnv(..), GhciMode(..),
  19                           ModGuts(..), ModGuts, Avails, availsToNameSet,
  20                           PackageRuleBase, HomePackageTable, ModDetails(..),
  21                           HomeModInfo(..)
  22                         )
  23 import CSE              ( cseProgram )
  24 import Rules            ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
  25                           extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
  26                           ruleCheckProgram )
  27 import Module           ( moduleEnvElts )
  28 import Name             ( Name, isExternalName )
  29 import NameSet          ( elemNameSet )
  30 import PprCore          ( pprCoreBindings, pprCoreExpr )
  31 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  32 import CoreUtils        ( coreBindsSize )
  33 import Simplify         ( simplTopBinds, simplExpr )
  34 import SimplUtils       ( simplBinders )
  35 import SimplMonad
  36 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  37 import CoreLint         ( endPass )
  38 import FloatIn          ( floatInwards )
  39 import FloatOut         ( floatOutwards )
  40 import Id               ( idName, setIdLocalExported )
  41 import VarSet
  42 import LiberateCase     ( liberateCase )
  43 import SAT              ( doStaticArgs )
  44 import Specialise       ( specProgram)
  45 import SpecConstr       ( specConstrProgram)
  46 import DmdAnal          ( dmdAnalPgm )
  47 import WorkWrap         ( wwTopBinds )
  48 #ifdef OLD_STRICTNESS
  49 import StrictAnal       ( saBinds )
  50 import CprAnalyse       ( cprAnalyse )
  51 #endif
  52
  53 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  54 import IO               ( hPutStr, stderr )
  55 import Outputable
  56
  57 import Maybes           ( orElse )
  58 import List             ( partition )
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection{The driver for the simplifier}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 core2core :: HscEnv
  69           -> PersistentCompilerState
  70           -> ModGuts
  71           -> IO ModGuts
  72
  73 core2core hsc_env pcs
  74           mod_impl@(ModGuts { mg_exports = exports,
  75                               mg_binds = binds_in,
  76                               mg_rules = rules_in })
  77   = do
  78         let dflags        = hsc_dflags hsc_env
  79             hpt           = hsc_HPT hsc_env
  80             ghci_mode     = hsc_mode hsc_env
  81             core_todos    = dopt_CoreToDo dflags
  82             pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
  83
  84         us <-  mkSplitUniqSupply 's'
  85         let (cp_us, ru_us) = splitUniqSupply us
  86
  87                 -- COMPUTE THE RULE BASE TO USE
  88         (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
  89                 <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
  90
  91                 -- PREPARE THE BINDINGS
  92         let binds1 = updateBinders ghci_mode local_rule_ids
  93                                    rule_rhs_fvs exports binds_in
  94
  95                 -- DO THE BUSINESS
  96         (stats, processed_binds)
  97                 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
  98
  99         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
 100                   "Grand total simplifier statistics"
 101                   (pprSimplCount stats)
 102
 103         -- Return results
 104         -- We only return local orphan rules, i.e., local rules not attached to an Id
 105         -- The bindings cotain more rules, embedded in the Ids
 106         return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
 107
 108
 109 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 110              -> CoreExpr
 111              -> IO CoreExpr
 112 -- simplifyExpr is called by the driver to simplify an
 113 -- expression typed in at the interactive prompt
 114 simplifyExpr dflags expr
 115   = do  {
 116         ; showPass dflags "Simplify"
 117
 118         ; us <-  mkSplitUniqSupply 's'
 119
 120         ; let env              = emptySimplEnv SimplGently [] emptyVarSet
 121               (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
 122
 123         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 124                         (pprCoreExpr expr')
 125
 126         ; return expr'
 127         }
 128
 129
 130 doCorePasses :: DynFlags
 131              -> RuleBase        -- the main rule base
 132              -> SimplCount      -- simplifier stats
 133              -> UniqSupply      -- uniques
 134              -> [CoreBind]      -- local binds in (with rules attached)
 135              -> [CoreToDo]      -- which passes to do
 136              -> IO (SimplCount, [CoreBind])  -- stats, binds, local orphan rules
 137
 138 doCorePasses dflags rb stats us binds []
 139   = return (stats, binds)
 140
 141 doCorePasses dflags rb stats us binds (to_do : to_dos)
 142   = do
 143         let (us1, us2) = splitUniqSupply us
 144
 145         (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
 146
 147         doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
 148
 149 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
 150    = _scc_ "Simplify"      simplifyPgm dfs rb mode switches us binds
 151 doCorePass dfs rb us binds CoreCSE
 152    = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
 153 doCorePass dfs rb us binds CoreLiberateCase
 154    = _scc_ "LiberateCase"  noStats dfs (liberateCase dfs binds)
 155 doCorePass dfs rb us binds CoreDoFloatInwards
 156    = _scc_ "FloatInwards"  noStats dfs (floatInwards dfs binds)
 157 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
 158    = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
 159 doCorePass dfs rb us binds CoreDoStaticArgs
 160    = _scc_ "StaticArgs"    noStats dfs (doStaticArgs us binds)
 161 doCorePass dfs rb us binds CoreDoStrictness
 162    = _scc_ "Stranal"       noStats dfs (dmdAnalPgm dfs binds)
 163 doCorePass dfs rb us binds CoreDoWorkerWrapper
 164    = _scc_ "WorkWrap"      noStats dfs (wwTopBinds dfs us binds)
 165 doCorePass dfs rb us binds CoreDoSpecialising
 166    = _scc_ "Specialise"    noStats dfs (specProgram dfs us binds)
 167 doCorePass dfs rb us binds CoreDoSpecConstr
 168    = _scc_ "SpecConstr"    noStats dfs (specConstrProgram dfs us binds)
 169 #ifdef OLD_STRICTNESS
 170 doCorePass dfs rb us binds CoreDoOldStrictness
 171    = _scc_ "OldStrictness"      noStats dfs (doOldStrictness dfs binds)
 172 #endif
 173 doCorePass dfs rb us binds CoreDoPrintCore
 174    = _scc_ "PrintCore"     noStats dfs (printCore binds)
 175 doCorePass dfs rb us binds CoreDoGlomBinds
 176    = noStats dfs (glomBinds dfs binds)
 177 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
 178    = noStats dfs (ruleCheck dfs phase pat binds)
 179 doCorePass dfs rb us binds CoreDoNothing
 180    = noStats dfs (return binds)
 181
 182 #ifdef OLD_STRICTNESS
 183 doOldStrictness dfs binds
 184   = do binds1 <- saBinds dfs binds
 185        binds2 <- cprAnalyse dfs binds1
 186        return binds2
 187 #endif
 188
 189 printCore binds = do dumpIfSet True "Print Core"
 190                                (pprCoreBindings binds)
 191                      return binds
 192
 193 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
 194                                       printDump (ruleCheckProgram phase pat binds)
 195                                       return binds
 196
 197 -- most passes return no stats and don't change rules
 198 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
 199
 200 \end{code}
 201
 202
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{Dealing with rules}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 211 -- It attaches those rules that are for local Ids to their binders, and
 212 -- returns the remainder attached to Ids in an IdSet.  It also returns
 213 -- Ids mentioned on LHS of some rule; these should be blacklisted.
 214
 215 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
 216 -- so that the opportunity to apply the rule isn't lost too soon
 217
 218 \begin{code}
 219 prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable
 220              -> UniqSupply
 221              -> [CoreBind]
 222              -> [IdCoreRule]            -- Local rules
 223              -> IO (RuleBase,           -- Full rule base
 224                     IdSet,              -- Local rule Ids
 225                     [IdCoreRule],       -- Orphan rules
 226                     IdSet)              -- RHS free vars of all rules
 227
 228 prepareRules dflags pkg_rule_base hpt us binds local_rules
 229   = do  { let env              = emptySimplEnv SimplGently [] local_ids
 230               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 231
 232         ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
 233                 -- We use (`elemVarSet` local_ids) rather than isLocalId because
 234                 -- isLocalId isn't true of class methods.
 235                 -- If we miss any rules for Ids defined here, then we end up
 236                 -- giving the local decl a new Unique (because the in-scope-set is the
 237                 -- same as the rule-id set), and now the binding for the class method
 238                 -- doesn't have the same Unique as the one in the Class and the tc-env
 239                 --      Example:        class Foo a where
 240                 --                        op :: a -> a
 241                 --                      {-# RULES "op" op x = x #-}
 242
 243               rule_rhs_fvs                = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
 244               local_rule_base             = extendRuleBaseList emptyRuleBase local_rules
 245               local_rule_ids              = ruleBaseIds local_rule_base -- Local Ids with rules attached
 246               imp_rule_base               = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
 247               rule_base                   = extendRuleBaseList imp_rule_base orphan_rules
 248               final_rule_base             = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
 249                 -- The last step black-lists the free vars of local rules too
 250
 251         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 252                 (vcat [text "Local rules", pprRuleBase local_rule_base,
 253                        text "",
 254                        text "Imported rules", pprRuleBase final_rule_base])
 255
 256         ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
 257     }
 258   where
 259     add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
 260
 261         -- Boringly, we need to gather the in-scope set.
 262     local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 263
 264
 265 updateBinders :: GhciMode
 266               -> IdSet                  -- Locally defined ids with their Rules attached
 267               -> IdSet                  -- Ids free in the RHS of local rules
 268               -> Avails                 -- What is exported
 269               -> [CoreBind] -> [CoreBind]
 270         -- A horrible function
 271
 272 -- Update the binders of top-level bindings as follows
 273 --      a) Attach the rules for each locally-defined Id to that Id.
 274 --      b) Set the no-discard flag if either the Id is exported,
 275 --         or it's mentioned in the RHS of a rule
 276 --
 277 -- You might wonder why exported Ids aren't already marked as such;
 278 -- it's just because the type checker is rather busy already and
 279 -- I didn't want to pass in yet another mapping.
 280 --
 281 -- Reason for (a)
 282 --      - It makes the rules easier to look up
 283 --      - It means that transformation rules and specialisations for
 284 --        locally defined Ids are handled uniformly
 285 --      - It keeps alive things that are referred to only from a rule
 286 --        (the occurrence analyser knows about rules attached to Ids)
 287 --      - It makes sure that, when we apply a rule, the free vars
 288 --        of the RHS are more likely to be in scope
 289 --
 290 -- Reason for (b)
 291 --     It means that the binding won't be discarded EVEN if the binding
 292 --     ends up being trivial (v = w) -- the simplifier would usually just
 293 --     substitute w for v throughout, but we don't apply the substitution to
 294 --     the rules (maybe we should?), so this substitution would make the rule
 295 --     bogus.
 296
 297 updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds
 298   = map update_bndrs binds
 299   where
 300     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 301     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 302
 303     update_bndr bndr
 304         | dont_discard bndr = setIdLocalExported bndr_with_rules
 305         | otherwise         = bndr_with_rules
 306         where
 307           bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
 308
 309     dont_discard bndr =  is_exported (idName bndr)
 310                       || bndr `elemVarSet` rule_rhs_fvs
 311
 312         -- In interactive mode, we don't want to discard any top-level
 313         -- entities at all (eg. do not inline them away during
 314         -- simplification), and retain them all in the TypeEnv so they are
 315         -- available from the command line.
 316         --
 317         -- isExternalName separates the user-defined top-level names from those
 318         -- introduced by the type checker.
 319     is_exported :: Name -> Bool
 320     is_exported | ghci_mode == Interactive = isExternalName
 321                 | otherwise                = (`elemNameSet` export_fvs)
 322
 323     export_fvs = availsToNameSet exports
 324 \end{code}
 325
 326
 327 We must do some gentle simplification on the template (but not the RHS)
 328 of each rule.  The case that forced me to add this was the fold/build rule,
 329 which without simplification looked like:
 330         fold k z (build (/\a. g a))  ==>  ...
 331 This doesn't match unless you do eta reduction on the build argument.
 332
 333 \begin{code}
 334 simplRule env rule@(id, BuiltinRule _ _)
 335   = returnSmpl rule
 336 simplRule env rule@(id, Rule act name bndrs args rhs)
 337   = simplBinders env bndrs              `thenSmpl` \ (env, bndrs') ->
 338     mapSmpl (simplExprGently env) args  `thenSmpl` \ args' ->
 339     simplExprGently env rhs             `thenSmpl` \ rhs' ->
 340     returnSmpl (id, Rule act name bndrs' args' rhs')
 341
 342 -- It's important that simplExprGently does eta reduction.
 343 -- For example, in a rule like:
 344 --      augment g (build h)
 345 -- we do not want to get
 346 --      augment (\a. g a) (build h)
 347 -- otherwise we don't match when given an argument like
 348 --      (\a. h a a)
 349 --
 350 -- The simplifier does indeed do eta reduction (it's in
 351 -- Simplify.completeLam) but only if -O is on.
 352 \end{code}
 353
 354 \begin{code}
 355 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 356 -- Simplifies an expression
 357 --      does occurrence analysis, then simplification
 358 --      and repeats (twice currently) because one pass
 359 --      alone leaves tons of crud.
 360 -- Used (a) for user expressions typed in at the interactive prompt
 361 --      (b) the LHS and RHS of a RULE
 362 --
 363 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 364 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 365 -- enforce that; it just simplifies the expression twice
 366
 367 simplExprGently env expr
 368   = simplExpr env (occurAnalyseGlobalExpr expr)         `thenSmpl` \ expr1 ->
 369     simplExpr env (occurAnalyseGlobalExpr expr1)
 370 \end{code}
 371
 372
 373 %************************************************************************
 374 %*                                                                      *
 375 \subsection{Glomming}
 376 %*                                                                      *
 377 %************************************************************************
 378
 379 \begin{code}
 380 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 381 -- Glom all binds together in one Rec, in case any
 382 -- transformations have introduced any new dependencies
 383 --
 384 -- NB: the global invariant is this:
 385 --      *** the top level bindings are never cloned, and are always unique ***
 386 --
 387 -- We sort them into dependency order, but applying transformation rules may
 388 -- make something at the top refer to something at the bottom:
 389 --      f = \x -> p (q x)
 390 --      h = \y -> 3
 391 --
 392 --      RULE:  p (q x) = h x
 393 --
 394 -- Applying this rule makes f refer to h,
 395 -- although it doesn't appear to in the source program.
 396 -- This pass lets us control where it happens.
 397 --
 398 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 399 -- function.  It only happens for rules whose head is an imported function
 400 -- (p in the example above).  So, for example, the rule had been
 401 --      RULE: f (p x) = h x
 402 -- then the rule for f would be attached to f itself (in its IdInfo)
 403 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 404 -- analyser as free in f.
 405
 406 glomBinds dflags binds
 407   = do { showPass dflags "GlomBinds" ;
 408          let { recd_binds = [Rec (flattenBinds binds)] } ;
 409          return recd_binds }
 410         -- Not much point in printing the result...
 411         -- just consumes output bandwidth
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsection{The driver for the simplifier}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 \begin{code}
 422 simplifyPgm :: DynFlags
 423             -> RuleBase
 424             -> SimplifierMode
 425             -> [SimplifierSwitch]
 426             -> UniqSupply
 427             -> [CoreBind]                   -- Input
 428             -> IO (SimplCount, [CoreBind])  -- New bindings
 429
 430 simplifyPgm dflags rule_base
 431             mode switches us binds
 432   = do {
 433         showPass dflags "Simplify";
 434
 435         (termination_msg, it_count, counts_out, binds')
 436            <- iteration us 1 (zeroSimplCount dflags) binds;
 437
 438         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 439                    && dopt Opt_D_dump_simpl_stats dflags)
 440                   "Simplifier statistics"
 441                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 442                          text "",
 443                          pprSimplCount counts_out]);
 444
 445         endPass dflags "Simplify" Opt_D_verbose_core2core binds';
 446
 447         return (counts_out, binds')
 448     }
 449   where
 450     phase_info        = case mode of
 451                           SimplGently  -> "gentle"
 452                           SimplPhase n -> show n
 453
 454     imported_rule_ids = ruleBaseIds rule_base
 455     simpl_env         = emptySimplEnv mode switches imported_rule_ids
 456     sw_chkr           = getSwitchChecker simpl_env
 457     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 458
 459     iteration us iteration_no counts binds
 460       -- Try and force thunks off the binds; significantly reduces
 461       -- space usage, especially with -O.  JRS, 000620.
 462       | let sz = coreBindsSize binds in sz == sz
 463       = do {
 464                 -- Occurrence analysis
 465            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 466
 467            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 468                      (pprCoreBindings tagged_binds);
 469
 470                 -- SIMPLIFY
 471                 -- We do this with a *case* not a *let* because lazy pattern
 472                 -- matching bit us with bad space leak!
 473                 -- With a let, we ended up with
 474                 --   let
 475                 --      t = initSmpl ...
 476                 --      counts' = snd t
 477                 --   in
 478                 --      case t of {(_,counts') -> if counts'=0 then ...
 479                 -- So the conditional didn't force counts', because the
 480                 -- selection got duplicated.  Sigh!
 481            case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
 482                 (binds', counts') -> do {
 483                         -- The imported_rule_ids are used by initSmpl to initialise
 484                         -- the in-scope set.  That way, the simplifier will change any
 485                         -- occurrences of the imported id to the one in the imported_rule_ids
 486                         -- set, which are decorated with their rules.
 487
 488            let { all_counts = counts `plusSimplCount` counts' ;
 489                  herald     = "Simplifier phase " ++ phase_info ++
 490                               ", iteration " ++ show iteration_no ++
 491                               " out of " ++ show max_iterations
 492                 } ;
 493
 494                 -- Stop if nothing happened; don't dump output
 495            if isZeroSimplCount counts' then
 496                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 497            else do {
 498
 499                 -- Dump the result of this iteration
 500            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 501                      (pprSimplCount counts') ;
 502
 503            endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 504
 505                 -- Stop if we've run out of iterations
 506            if iteration_no == max_iterations then
 507                 do {
 508 #ifdef DEBUG
 509                     if  max_iterations > 2 then
 510                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 511                                     show max_iterations ++
 512                                     " iterations; bailing out.\n")
 513                     else
 514 #endif
 515                         return ();
 516
 517                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 518                 }
 519
 520                 -- Else loop
 521            else iteration us2 (iteration_no + 1) all_counts binds'
 522         }  } } }
 523       where
 524           (us1, us2) = splitUniqSupply us
 525 \end{code}