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