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