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