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