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