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