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                           SwitchResult(..), intSwitchSet,
  13                           DynFlags, DynFlag(..), dopt, dopt_CoreToDo
  14                         )
  15 import CoreLint         ( showPass, endPass )
  16 import CoreSyn
  17 import CoreFVs          ( ruleRhsFreeVars )
  18 import HscTypes         ( PersistentCompilerState(..),
  19                           PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
  20                         )
  21 import CSE              ( cseProgram )
  22 import Rules            ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
  23                           extendRuleBaseList, addRuleBaseFVs, pprRuleBase )
  24 import Module           ( moduleEnvElts )
  25 import CoreUnfold
  26 import PprCore          ( pprCoreBindings, pprCoreExpr )
  27 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  28 import CoreUtils        ( coreBindsSize )
  29 import Simplify         ( simplTopBinds, simplExpr )
  30 import SimplUtils       ( simplBinders )
  31 import SimplMonad
  32 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn )
  33 import FloatIn          ( floatInwards )
  34 import FloatOut         ( floatOutwards )
  35 import Id               ( idName, isDataConWrapId, setIdNoDiscard, isImplicitId )
  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 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 (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_nothing
 113                                           (simplExprGently expr)
 114
 115         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 116                         (pprCoreExpr expr')
 117
 118         ; return expr'
 119         }
 120   where
 121     sw_chkr any          = SwBool False -- A bit bogus
 122     black_list_nothing v = False        -- Black list nothing
 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 sw_chkr)
 145    = _scc_ "Simplify"      simplifyPgm dfs rb sw_chkr 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 (saBinds 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 doCorePass dfs rb us binds CoreDoCPResult
 165    = _scc_ "CPResult"      noStats dfs (cprAnalyse dfs binds)
 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 CoreDoNothing
 173    = noStats dfs (return binds)
 174
 175 printCore binds = do dumpIfSet True "Print Core"
 176                                (pprCoreBindings binds)
 177                      return binds
 178
 179 -- most passes return no stats and don't change rules
 180 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
 181 \end{code}
 182
 183
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection{Dealing with rules}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 192 -- It attaches those rules that are for local Ids to their binders, and
 193 -- returns the remainder attached to Ids in an IdSet.  It also returns
 194 -- Ids mentioned on LHS of some rule; these should be blacklisted.
 195
 196 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
 197 -- so that the opportunity to apply the rule isn't lost too soon
 198
 199 \begin{code}
 200 prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
 201              -> UniqSupply
 202              -> [CoreBind]
 203              -> [IdCoreRule]            -- Local rules
 204              -> IO (RuleBase,           -- Full rule base
 205                     IdSet,              -- Local rule Ids
 206                     [IdCoreRule],       -- Orphan rules
 207                     IdSet)              -- RHS free vars of all rules
 208
 209 prepareRules dflags pkg_rule_base hst us binds local_rules
 210   = do  { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
 211                                           (mapSmpl simplRule local_rules)
 212
 213         ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
 214                 -- We use (`elemVarSet` local_ids) rather than isLocalId because
 215                 -- isLocalId isn't true of class methods.
 216                 -- If we miss any rules for Ids defined here, then we end up
 217                 -- giving the local decl a new Unique (because the in-scope-set is the
 218                 -- same as the rule-id set), and now the binding for the class method
 219                 -- doesn't have the same Unique as the one in the Class and the tc-env
 220                 --      Example:        class Foo a where
 221                 --                        op :: a -> a
 222                 --                      {-# RULES "op" op x = x #-}
 223
 224               rule_rhs_fvs                = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
 225               local_rule_base             = extendRuleBaseList emptyRuleBase local_rules
 226               local_rule_ids              = ruleBaseIds local_rule_base -- Local Ids with rules attached
 227               imp_rule_base               = foldl add_rules pkg_rule_base (moduleEnvElts hst)
 228               rule_base                   = extendRuleBaseList imp_rule_base orphan_rules
 229               final_rule_base             = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
 230                 -- The last step black-lists the free vars of local rules too
 231
 232         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 233                 (vcat [text "Local rules", pprRuleBase local_rule_base,
 234                        text "",
 235                        text "Imported rules", pprRuleBase final_rule_base])
 236
 237         ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
 238     }
 239   where
 240     sw_chkr any      = SwBool False                     -- A bit bogus
 241     black_list_all v = not (isDataConWrapId v)
 242                 -- This stops all inlining except the
 243                 -- wrappers for data constructors
 244
 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      -- Constructors, selectors; doesn't
 286                                         -- make sense to call setIdNoDiscard
 287                                         -- Also can't have rules
 288         | dont_discard bndr = setIdNoDiscard bndr_with_rules
 289         | otherwise         = bndr_with_rules
 290         where
 291           bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
 292
 293     dont_discard bndr =  is_exported (idName bndr)
 294                       || bndr `elemVarSet` rule_rhs_fvs
 295 \end{code}
 296
 297
 298 We must do some gentle simplification on the template (but not the RHS)
 299 of each rule.  The case that forced me to add this was the fold/build rule,
 300 which without simplification looked like:
 301         fold k z (build (/\a. g a))  ==>  ...
 302 This doesn't match unless you do eta reduction on the build argument.
 303
 304 \begin{code}
 305 simplRule rule@(id, BuiltinRule _)
 306   = returnSmpl rule
 307 simplRule rule@(id, Rule name bndrs args rhs)
 308   = simplBinders bndrs                  $ \ bndrs' ->
 309     mapSmpl simplExprGently args        `thenSmpl` \ args' ->
 310     simplExprGently rhs                 `thenSmpl` \ rhs' ->
 311     returnSmpl (id, Rule name bndrs' args' rhs')
 312
 313 -- It's important that simplExprGently does eta reduction.
 314 -- For example, in a rule like:
 315 --      augment g (build h)
 316 -- we do not want to get
 317 --      augment (\a. g a) (build h)
 318 -- otherwise we don't match when given an argument like
 319 --      (\a. h a a)
 320 --
 321 -- The simplifier does indeed do eta reduction (it's in
 322 -- Simplify.completeLam) but only if -O is on.
 323 \end{code}
 324
 325 \begin{code}
 326 simplExprGently :: CoreExpr -> SimplM CoreExpr
 327 -- Simplifies an expression
 328 --      does occurrence analysis, then simplification
 329 --      and repeats (twice currently) because one pass
 330 --      alone leaves tons of crud.
 331 -- Used (a) for user expressions typed in at the interactive prompt
 332 --      (b) the LHS and RHS of a RULE
 333 simplExprGently expr
 334   = simplExpr (occurAnalyseGlobalExpr expr)     `thenSmpl` \ expr1 ->
 335     simplExpr (occurAnalyseGlobalExpr expr1)
 336 \end{code}
 337
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsection{Glomming}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 \begin{code}
 346 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 347 -- Glom all binds together in one Rec, in case any
 348 -- transformations have introduced any new dependencies
 349 --
 350 -- NB: the global invariant is this:
 351 --      *** the top level bindings are never cloned, and are always unique ***
 352 --
 353 -- We sort them into dependency order, but applying transformation rules may
 354 -- make something at the top refer to something at the bottom:
 355 --      f = \x -> p (q x)
 356 --      h = \y -> 3
 357 --
 358 --      RULE:  p (q x) = h x
 359 --
 360 -- Applying this rule makes f refer to h,
 361 -- although it doesn't appear to in the source program.
 362 -- This pass lets us control where it happens.
 363 --
 364 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 365 -- function.  It only happens for rules whose head is an imported function
 366 -- (p in the example above).  So, for example, the rule had been
 367 --      RULE: f (p x) = h x
 368 -- then the rule for f would be attached to f itself (in its IdInfo)
 369 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 370 -- analyser as free in f.
 371
 372 glomBinds dflags binds
 373   = do { showPass dflags "GlomBinds" ;
 374          let { recd_binds = [Rec (flattenBinds binds)] } ;
 375          return recd_binds }
 376         -- Not much point in printing the result...
 377         -- just consumes output bandwidth
 378 \end{code}
 379
 380
 381 %************************************************************************
 382 %*                                                                      *
 383 \subsection{The driver for the simplifier}
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 \begin{code}
 388 simplifyPgm :: DynFlags
 389             -> RuleBase
 390             -> (SimplifierSwitch -> SwitchResult)
 391             -> UniqSupply
 392             -> [CoreBind]                   -- Input
 393             -> IO (SimplCount, [CoreBind])  -- New bindings
 394
 395 simplifyPgm dflags rule_base
 396             sw_chkr us binds
 397   = do {
 398         showPass dflags "Simplify";
 399
 400         (termination_msg, it_count, counts_out, binds')
 401            <- iteration us 1 (zeroSimplCount dflags) binds;
 402
 403         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 404                    && dopt Opt_D_dump_simpl_stats dflags)
 405                   "Simplifier statistics"
 406                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 407                          text "",
 408                          pprSimplCount counts_out]);
 409
 410         endPass dflags "Simplify" Opt_D_verbose_core2core binds';
 411
 412         return (counts_out, binds')
 413     }
 414   where
 415     max_iterations    = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 416     black_list_fn     = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
 417     imported_rule_ids = ruleBaseIds rule_base
 418     rule_lhs_fvs      = ruleBaseFVs rule_base
 419
 420     iteration us iteration_no counts binds
 421       -- Try and force thunks off the binds; significantly reduces
 422       -- space usage, especially with -O.  JRS, 000620.
 423       | let sz = coreBindsSize binds in sz == sz
 424       = do {
 425                 -- Occurrence analysis
 426            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 427
 428            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 429                      (pprCoreBindings tagged_binds);
 430
 431                 -- SIMPLIFY
 432                 -- We do this with a *case* not a *let* because lazy pattern
 433                 -- matching bit us with bad space leak!
 434                 -- With a let, we ended up with
 435                 --   let
 436                 --      t = initSmpl ...
 437                 --      counts' = snd t
 438                 --   in
 439                 --      case t of {(_,counts') -> if counts'=0 then ...
 440                 -- So the conditional didn't force counts', because the
 441                 -- selection got duplicated.  Sigh!
 442            case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
 443                          (simplTopBinds tagged_binds)
 444                 of { (binds', counts') -> do {
 445                         -- The imported_rule_ids are used by initSmpl to initialise
 446                         -- the in-scope set.  That way, the simplifier will change any
 447                         -- occurrences of the imported id to the one in the imported_rule_ids
 448                         -- set, which are decorated with their rules.
 449
 450            let { all_counts = counts `plusSimplCount` counts' } ;
 451
 452                 -- Stop if nothing happened; don't dump output
 453            if isZeroSimplCount counts' then
 454                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 455            else do {
 456
 457                 -- Dump the result of this iteration
 458            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
 459                      ("Simplifier iteration " ++ show iteration_no
 460                       ++ " out of " ++ show max_iterations)
 461                      (pprSimplCount counts') ;
 462
 463            endPass dflags
 464                     ("Simplifier iteration " ++ show iteration_no ++ " result")
 465                     Opt_D_dump_simpl_iterations
 466                     binds' ;
 467
 468                 -- Stop if we've run out of iterations
 469            if iteration_no == max_iterations then
 470                 do {
 471 #ifdef DEBUG
 472                     if  max_iterations > 2 then
 473                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 474                                     show max_iterations ++
 475                                     " iterations; bailing out.\n")
 476                     else
 477 #endif
 478                         return ();
 479
 480                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 481                 }
 482
 483                 -- Else loop
 484            else iteration us2 (iteration_no + 1) all_counts binds'
 485         }  } } }
 486       where
 487           (us1, us2) = splitUniqSupply us
 488 \end{code}