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