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