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