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