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