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                           DynFlags, DynFlag(..), dopt, dopt_CoreToDo
  14                         )
  15 import CoreLint         ( showPass, endPass )
  16 import CoreSyn
  17 import CoreFVs          ( ruleRhsFreeVars )
  18 import HscTypes         ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) )
  19 import CSE              ( cseProgram )
  20 import Rules            ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
  21                           extendRuleBaseList, addRuleBaseFVs )
  22 import Module           ( moduleEnvElts )
  23 import CoreUnfold
  24 import PprCore          ( pprCoreBindings, pprIdCoreRule )
  25 import OccurAnal        ( occurAnalyseBinds )
  26 import CoreUtils        ( etaReduceExpr, coreBindsSize )
  27 import Simplify         ( simplTopBinds, simplExpr )
  28 import SimplUtils       ( simplBinders )
  29 import SimplMonad
  30 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn )
  31 import FloatIn          ( floatInwards )
  32 import FloatOut         ( floatOutwards )
  33 import Id               ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
  34 import VarSet
  35 import LiberateCase     ( liberateCase )
  36 import SAT              ( doStaticArgs )
  37 import Specialise       ( specProgram)
  38 import UsageSPInf       ( doUsageSPInf )
  39 import StrictAnal       ( saBinds )
  40 import WorkWrap         ( wwTopBinds )
  41 import CprAnalyse       ( cprAnalyse )
  42
  43 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  44 import IO               ( hPutStr, stderr )
  45 import Outputable
  46
  47 import Maybes           ( orElse )
  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 binds 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              -> [CoreBind]
 169              -> [IdCoreRule]            -- Local rules
 170              -> IO (RuleBase,           -- Full rule base
 171                     (IdSet,IdSet),      -- Local rule Ids, and RHS fvs
 172                     [IdCoreRule])       -- Orphan rules
 173
 174 prepareRules dflags pkg_rule_base hst us binds rules
 175   = do  { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
 176                                           (mapSmpl simplRule rules)
 177
 178         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 179                         (vcat (map pprIdCoreRule better_rules))
 180
 181         ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
 182               local_rule_rhs_fvs          = unionVarSets (map (ruleRhsFreeVars . snd) local_rules)
 183               local_rule_base             = extendRuleBaseList emptyRuleBase local_rules
 184               local_rule_ids              = ruleBaseIds local_rule_base -- Local Ids with rules attached
 185               imp_rule_base               = foldl add_rules pkg_rule_base (moduleEnvElts hst)
 186               rule_base                   = extendRuleBaseList imp_rule_base orphan_rules
 187               final_rule_base             = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
 188                 -- The last step black-lists the free vars of local rules too
 189
 190         ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules)
 191     }
 192   where
 193     sw_chkr any      = SwBool False                     -- A bit bogus
 194     black_list_all v = not (isDataConWrapId v)
 195                 -- This stops all inlining except the
 196                 -- wrappers for data constructors
 197
 198     add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
 199
 200         -- Boringly, we need to gather the in-scope set.
 201         -- Typically this thunk won't even be forced, but the test in
 202         -- simpVar fails if it isn't right, and it might conceiveably matter
 203     local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 204
 205
 206 updateBinders :: (IdSet,                -- Locally defined ids with their Rules attached
 207                   IdSet)                -- Ids free in the RHS of local rules
 208               -> IsExported
 209               -> [CoreBind] -> [CoreBind]
 210         -- A horrible function
 211
 212 -- Update the binders of top-level bindings as follows
 213 --      a) Attach the rules for each locally-defined Id to that Id.
 214 --      b) Set the no-discard flag if either the Id is exported,
 215 --         or it's mentoined in the RHS of a rule
 216 --
 217 -- Reason for (a)
 218 --      - It makes the rules easier to look up
 219 --      - It means that transformation rules and specialisations for
 220 --        locally defined Ids are handled uniformly
 221 --      - It keeps alive things that are referred to only from a rule
 222 --        (the occurrence analyser knows about rules attached to Ids)
 223 --      - It makes sure that, when we apply a rule, the free vars
 224 --        of the RHS are more likely to be in scope
 225 --
 226 -- Reason for (b)
 227 --     It means that the binding won't be discarded EVEN if the binding
 228 --     ends up being trivial (v = w) -- the simplifier would usually just
 229 --     substitute w for v throughout, but we don't apply the substitution to
 230 --     the rules (maybe we should?), so this substitution would make the rule
 231 --     bogus.
 232
 233 updateBinders (rule_ids, rule_rhs_fvs) is_exported binds
 234   = map update_bndrs binds
 235   where
 236     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 237     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 238
 239     update_bndr bndr
 240         |  is_exported (idName bndr)
 241         || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr'
 242         | otherwise                       = bndr'
 243         where
 244           bndr' = lookupVarSet rule_ids bndr `orElse` bndr
 245 \end{code}
 246
 247
 248 We must do some gentle simplification on the template (but not the RHS)
 249 of each rule.  The case that forced me to add this was the fold/build rule,
 250 which without simplification looked like:
 251         fold k z (build (/\a. g a))  ==>  ...
 252 This doesn't match unless you do eta reduction on the build argument.
 253
 254 \begin{code}
 255 simplRule rule@(id, BuiltinRule _)
 256   = returnSmpl rule
 257 simplRule rule@(id, Rule name bndrs args rhs)
 258   = simplBinders bndrs                  $ \ bndrs' ->
 259     mapSmpl simpl_arg args              `thenSmpl` \ args' ->
 260     simplExpr rhs                       `thenSmpl` \ rhs' ->
 261     returnSmpl (id, Rule name bndrs' args' rhs')
 262
 263 simpl_arg e
 264 --  I've seen rules in which a LHS like
 265 --      augment g (build h)
 266 -- turns into
 267 --      augment (\a. g a) (build h)
 268 -- So it's a help to eta-reduce the args as we simplify them.
 269 -- Otherwise we don't match when given an argument like
 270 --      (\a. h a a)
 271   = simplExpr e         `thenSmpl` \ e' ->
 272     returnSmpl (etaReduceExpr e')
 273 \end{code}
 274
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsection{Glomming}
 279 %*                                                                      *
 280 %************************************************************************
 281
 282 \begin{code}
 283 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 284 -- Glom all binds together in one Rec, in case any
 285 -- transformations have introduced any new dependencies
 286 --
 287 -- NB: the global invariant is this:
 288 --      *** the top level bindings are never cloned, and are always unique ***
 289 --
 290 -- We sort them into dependency order, but applying transformation rules may
 291 -- make something at the top refer to something at the bottom:
 292 --      f = \x -> p (q x)
 293 --      h = \y -> 3
 294 --
 295 --      RULE:  p (q x) = h x
 296 --
 297 -- Applying this rule makes f refer to h,
 298 -- although it doesn't appear to in the source program.
 299 -- This pass lets us control where it happens.
 300 --
 301 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 302 -- function.  It only happens for rules whose head is an imported function
 303 -- (p in the example above).  So, for example, the rule had been
 304 --      RULE: f (p x) = h x
 305 -- then the rule for f would be attached to f itself (in its IdInfo)
 306 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 307 -- analyser as free in f.
 308
 309 glomBinds dflags binds
 310   = do { showPass dflags "GlomBinds" ;
 311          let { recd_binds = [Rec (flattenBinds binds)] } ;
 312          return recd_binds }
 313         -- Not much point in printing the result...
 314         -- just consumes output bandwidth
 315 \end{code}
 316
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection{The driver for the simplifier}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 simplifyPgm :: DynFlags
 326             -> RuleBase
 327             -> (SimplifierSwitch -> SwitchResult)
 328             -> UniqSupply
 329             -> [CoreBind]                   -- Input
 330             -> IO (SimplCount, [CoreBind])  -- New bindings
 331
 332 simplifyPgm dflags rule_base
 333             sw_chkr us binds
 334   = do {
 335         showPass dflags "Simplify";
 336
 337         (termination_msg, it_count, counts_out, binds')
 338            <- iteration us 1 (zeroSimplCount dflags) binds;
 339
 340         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 341                    && dopt Opt_D_dump_simpl_stats dflags)
 342                   "Simplifier statistics"
 343                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 344                          text "",
 345                          pprSimplCount counts_out]);
 346
 347         endPass dflags "Simplify"
 348                 (dopt Opt_D_verbose_core2core dflags
 349                  && not (dopt Opt_D_dump_simpl_iterations dflags))
 350                 binds' ;
 351
 352         return (counts_out, binds')
 353     }
 354   where
 355     max_iterations    = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 356     black_list_fn     = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
 357     imported_rule_ids = ruleBaseIds rule_base
 358     rule_lhs_fvs      = ruleBaseFVs rule_base
 359
 360     iteration us iteration_no counts binds
 361       -- Try and force thunks off the binds; significantly reduces
 362       -- space usage, especially with -O.  JRS, 000620.
 363       | let sz = coreBindsSize binds in sz == sz
 364       = do {
 365                 -- Occurrence analysis
 366            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 367
 368            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 369                      (pprCoreBindings tagged_binds);
 370
 371                 -- SIMPLIFY
 372                 -- We do this with a *case* not a *let* because lazy pattern
 373                 -- matching bit us with bad space leak!
 374                 -- With a let, we ended up with
 375                 --   let
 376                 --      t = initSmpl ...
 377                 --      counts' = snd t
 378                 --   in
 379                 --      case t of {(_,counts') -> if counts'=0 then ...
 380                 -- So the conditional didn't force counts', because the
 381                 -- selection got duplicated.  Sigh!
 382            case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
 383                          (simplTopBinds tagged_binds)
 384                 of { (binds', counts') -> do {
 385                         -- The imported_rule_ids are used by initSmpl to initialise
 386                         -- the in-scope set.  That way, the simplifier will change any
 387                         -- occurrences of the imported id to the one in the imported_rule_ids
 388                         -- set, which are decorated with their rules.
 389
 390            let { all_counts = counts `plusSimplCount` counts' } ;
 391
 392                 -- Stop if nothing happened; don't dump output
 393            if isZeroSimplCount counts' then
 394                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 395            else do {
 396
 397                 -- Dump the result of this iteration
 398            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
 399                      ("Simplifier iteration " ++ show iteration_no
 400                       ++ " out of " ++ show max_iterations)
 401                      (pprSimplCount counts') ;
 402
 403            if dopt Opt_D_dump_simpl_iterations dflags then
 404                 endPass dflags
 405                         ("Simplifier iteration " ++ show iteration_no ++ " result")
 406                         (dopt Opt_D_verbose_core2core dflags)
 407                         binds'
 408            else
 409                 return [] ;
 410
 411                 -- Stop if we've run out of iterations
 412            if iteration_no == max_iterations then
 413                 do {
 414 #ifdef DEBUG
 415                     if  max_iterations > 2 then
 416                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 417                                     show max_iterations ++
 418                                     " iterations; bailing out.\n")
 419                     else
 420 #endif
 421                         return ();
 422
 423                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 424                 }
 425
 426                 -- Else loop
 427            else iteration us2 (iteration_no + 1) all_counts binds'
 428         }  } } }
 429       where
 430           (us1, us2) = splitUniqSupply us
 431 \end{code}