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