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, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase,
  20                           prepareOrphanRuleBase, unionRuleBase, localRule )
  21 import CoreUnfold
  22 import PprCore          ( pprCoreBindings )
  23 import OccurAnal        ( occurAnalyseBinds )
  24 import CoreUtils        ( exprIsTrivial, etaReduceExpr, coreBindsSize )
  25 import Simplify         ( simplTopBinds, simplExpr )
  26 import SimplUtils       ( simplBinders )
  27 import SimplMonad
  28 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn )
  29 import FloatIn          ( floatInwards )
  30 import FloatOut         ( floatOutwards )
  31 import Id               ( isDataConWrapId )
  32 import VarSet
  33 import LiberateCase     ( liberateCase )
  34 import SAT              ( doStaticArgs )
  35 import Specialise       ( specProgram)
  36 import UsageSPInf       ( doUsageSPInf )
  37 import StrictAnal       ( saBinds )
  38 import WorkWrap         ( wwTopBinds )
  39 import CprAnalyse       ( cprAnalyse )
  40
  41 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  42 import IO               ( hPutStr, stderr )
  43 import Outputable
  44
  45 import List             ( partition )
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{The driver for the simplifier}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 core2core :: DynFlags
  56           -> [CoreToDo]         -- Spec of what core-to-core passes to do
  57           -> [CoreBind]         -- Binds in
  58           -> [ProtoCoreRule]    -- Rules in
  59           -> IO ([CoreBind], RuleBase)  -- binds, local orphan rules out
  60
  61 core2core dflags core_todos binds rules
  62   = do
  63         us <-  mkSplitUniqSupply 's'
  64         let (cp_us, ru_us) = splitUniqSupply us
  65
  66         let (local_rules, imported_rules) = partition localRule rules
  67
  68         better_local_rules <- simplRules dflags ru_us local_rules binds
  69
  70         let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
  71             imported_rule_base        = prepareOrphanRuleBase imported_rules
  72
  73         -- Do the main business
  74         (stats, processed_binds, processed_local_rules)
  75             <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 local_rule_base
  76                             imported_rule_base Nothing core_todos
  77
  78         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  79                   "Grand total simplifier statistics"
  80                   (pprSimplCount stats)
  81
  82         -- Return results
  83         -- We only return local orphan rules, i.e., local rules not attached to an Id
  84         return (processed_binds, processed_local_rules)
  85
  86
  87 doCorePasses :: DynFlags
  88              -> SimplCount      -- simplifier stats
  89              -> UniqSupply      -- uniques
  90              -> [CoreBind]      -- local binds in (with rules attached)
  91              -> RuleBase        -- local orphan rules
  92              -> RuleBase        -- imported and builtin rules
  93              -> Maybe RuleBase  -- combined rulebase, or Nothing to ask for it to be rebuilt
  94              -> [CoreToDo]      -- which passes to do
  95              -> IO (SimplCount, [CoreBind], RuleBase)  -- stats, binds, local orphan rules
  96
  97 doCorePasses dflags stats us binds lrb irb rb0 []
  98   = return (stats, binds, lrb)
  99
 100 doCorePasses dflags stats us binds lrb irb rb0 (to_do : to_dos)
 101   = do
 102         let (us1, us2) = splitUniqSupply us
 103
 104         -- recompute rulebase if necessary
 105         let rb         = maybe (irb `unionRuleBase` lrb) id rb0
 106
 107         (stats1, binds1, mlrb1) <- doCorePass dflags us1 binds lrb rb to_do
 108
 109         -- request rulebase recomputation if pass returned a new local rulebase
 110         let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1
 111
 112         doCorePasses dflags (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
 113
 114 doCorePass dfs us binds lrb rb (CoreDoSimplify sw_chkr)
 115    = _scc_ "Simplify"      simplifyPgm dfs rb sw_chkr us binds
 116 doCorePass dfs us binds lrb rb CoreCSE
 117    = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
 118 doCorePass dfs us binds lrb rb CoreLiberateCase
 119    = _scc_ "LiberateCase"  noStats dfs (liberateCase dfs binds)
 120 doCorePass dfs us binds lrb rb CoreDoFloatInwards
 121    = _scc_ "FloatInwards"  noStats dfs (floatInwards dfs binds)
 122 doCorePass dfs us binds lrb rb (CoreDoFloatOutwards f)
 123    = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
 124 doCorePass dfs us binds lrb rb CoreDoStaticArgs
 125    = _scc_ "StaticArgs"    noStats dfs (doStaticArgs us binds)
 126 doCorePass dfs us binds lrb rb CoreDoStrictness
 127    = _scc_ "Stranal"       noStats dfs (saBinds dfs binds)
 128 doCorePass dfs us binds lrb rb CoreDoWorkerWrapper
 129    = _scc_ "WorkWrap"      noStats dfs (wwTopBinds dfs us binds)
 130 doCorePass dfs us binds lrb rb CoreDoSpecialising
 131    = _scc_ "Specialise"    noStats dfs (specProgram dfs us binds)
 132 doCorePass dfs us binds lrb rb CoreDoCPResult
 133    = _scc_ "CPResult"      noStats dfs (cprAnalyse dfs binds)
 134 doCorePass dfs us binds lrb rb CoreDoPrintCore
 135    = _scc_ "PrintCore"     noStats dfs (printCore binds)
 136 doCorePass dfs us binds lrb rb CoreDoUSPInf
 137    = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds lrb)
 138 doCorePass dfs us binds lrb rb CoreDoGlomBinds
 139    = noStats dfs (glomBinds dfs 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, Nothing) }
 147 \end{code}
 148
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Dealing with rules}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 We must do some gentle simplification on the template (but not the RHS)
 158 of each rule.  The case that forced me to add this was the fold/build rule,
 159 which without simplification looked like:
 160         fold k z (build (/\a. g a))  ==>  ...
 161 This doesn't match unless you do eta reduction on the build argument.
 162
 163 \begin{code}
 164 simplRules :: DynFlags -> UniqSupply -> [ProtoCoreRule] -> [CoreBind]
 165            -> IO [ProtoCoreRule]
 166 simplRules dflags us rules binds
 167   = do  let (better_rules,_)
 168                = initSmpl dflags sw_chkr us bind_vars black_list_all
 169                           (mapSmpl simplRule rules)
 170
 171         dumpIfSet_dyn dflags Opt_D_dump_rules
 172                   "Transformation rules"
 173                   (vcat (map pprProtoCoreRule better_rules))
 174
 175         return better_rules
 176   where
 177     black_list_all v = not (isDataConWrapId v)
 178                 -- This stops all inlining except the
 179                 -- wrappers for data constructors
 180
 181     sw_chkr any = SwBool False                  -- A bit bogus
 182
 183         -- Boringly, we need to gather the in-scope set.
 184         -- Typically this thunk won't even be force, but the test in
 185         -- simpVar fails if it isn't right, and it might conceivably matter
 186     bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 187
 188
 189 simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _))
 190   = returnSmpl rule
 191 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
 192   | not is_local
 193   = returnSmpl rule     -- No need to fiddle with imported rules
 194   | otherwise
 195   = simplBinders bndrs                  $ \ bndrs' ->
 196     mapSmpl simpl_arg args              `thenSmpl` \ args' ->
 197     simplExpr rhs                       `thenSmpl` \ rhs' ->
 198     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
 199
 200 simpl_arg e
 201 --  I've seen rules in which a LHS like
 202 --      augment g (build h)
 203 -- turns into
 204 --      augment (\a. g a) (build h)
 205 -- So it's a help to eta-reduce the args as we simplify them.
 206 -- Otherwise we don't match when given an argument like
 207 --      (\a. h a a)
 208   = simplExpr e         `thenSmpl` \ e' ->
 209     returnSmpl (etaReduceExpr e')
 210 \end{code}
 211
 212 \begin{code}
 213 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 214 -- Glom all binds together in one Rec, in case any
 215 -- transformations have introduced any new dependencies
 216 --
 217 -- NB: the global invariant is this:
 218 --      *** the top level bindings are never cloned, and are always unique ***
 219 --
 220 -- We sort them into dependency order, but applying transformation rules may
 221 -- make something at the top refer to something at the bottom:
 222 --      f = \x -> p (q x)
 223 --      h = \y -> 3
 224 --
 225 --      RULE:  p (q x) = h x
 226 --
 227 -- Applying this rule makes f refer to h,
 228 -- although it doesn't appear to in the source program.
 229 -- This pass lets us control where it happens.
 230 --
 231 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 232 -- function.  It only happens for rules whose head is an imported function
 233 -- (p in the example above).  So, for example, the rule had been
 234 --      RULE: f (p x) = h x
 235 -- then the rule for f would be attached to f itself (in its IdInfo)
 236 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 237 -- analyser as free in f.
 238
 239 glomBinds dflags binds
 240   = do { beginPass dflags "GlomBinds" ;
 241          let { recd_binds = [Rec (flattenBinds binds)] } ;
 242          return recd_binds }
 243         -- Not much point in printing the result...
 244         -- just consumes output bandwidth
 245 \end{code}
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 \subsection{The driver for the simplifier}
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 \begin{code}
 254 simplifyPgm :: DynFlags
 255             -> RuleBase
 256             -> (SimplifierSwitch -> SwitchResult)
 257             -> UniqSupply
 258             -> [CoreBind]                                   -- Input
 259             -> IO (SimplCount, [CoreBind], Maybe RuleBase)  -- New bindings
 260
 261 simplifyPgm dflags (imported_rule_ids, rule_lhs_fvs)
 262             sw_chkr us binds
 263   = do {
 264         beginPass dflags "Simplify";
 265
 266         (termination_msg, it_count, counts_out, binds')
 267            <- iteration us 1 (zeroSimplCount dflags) binds;
 268
 269         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 270                    && dopt Opt_D_dump_simpl_stats dflags)
 271                   "Simplifier statistics"
 272                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 273                          text "",
 274                          pprSimplCount counts_out]);
 275
 276         endPass dflags "Simplify"
 277                 (dopt Opt_D_verbose_core2core dflags
 278                  && not (dopt Opt_D_dump_simpl_iterations dflags))
 279                 binds' ;
 280
 281         return (counts_out, binds', Nothing)
 282     }
 283   where
 284     max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 285     black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
 286
 287     iteration us iteration_no counts binds
 288       -- Try and force thunks off the binds; significantly reduces
 289       -- space usage, especially with -O.  JRS, 000620.
 290       | let sz = coreBindsSize binds in sz == sz
 291       = do {
 292                 -- Occurrence analysis
 293            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 294
 295            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 296                      (pprCoreBindings tagged_binds);
 297
 298                 -- SIMPLIFY
 299                 -- We do this with a *case* not a *let* because lazy pattern
 300                 -- matching bit us with bad space leak!
 301                 -- With a let, we ended up with
 302                 --   let
 303                 --      t = initSmpl ...
 304                 --      counts' = snd t
 305                 --   in
 306                 --      case t of {(_,counts') -> if counts'=0 then ...
 307                 -- So the conditional didn't force counts', because the
 308                 -- selection got duplicated.  Sigh!
 309            case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
 310                          (simplTopBinds tagged_binds)
 311                 of { (binds', counts') -> do {
 312                         -- The imported_rule_ids are used by initSmpl to initialise
 313                         -- the in-scope set.  That way, the simplifier will change any
 314                         -- occurrences of the imported id to the one in the imported_rule_ids
 315                         -- set, which are decorated with their rules.
 316
 317            let { all_counts = counts `plusSimplCount` counts' } ;
 318
 319                 -- Stop if nothing happened; don't dump output
 320            if isZeroSimplCount counts' then
 321                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 322            else do {
 323
 324                 -- Dump the result of this iteration
 325            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
 326                      ("Simplifier iteration " ++ show iteration_no
 327                       ++ " out of " ++ show max_iterations)
 328                      (pprSimplCount counts') ;
 329
 330            if dopt Opt_D_dump_simpl_iterations dflags then
 331                 endPass dflags
 332                         ("Simplifier iteration " ++ show iteration_no ++ " result")
 333                         (dopt Opt_D_verbose_core2core dflags)
 334                         binds'
 335            else
 336                 return [] ;
 337
 338                 -- Stop if we've run out of iterations
 339            if iteration_no == max_iterations then
 340                 do {
 341 #ifdef DEBUG
 342                     if  max_iterations > 2 then
 343                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 344                                     show max_iterations ++
 345                                     " iterations; bailing out.\n")
 346                     else
 347 #endif
 348                         return ();
 349
 350                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 351                 }
 352
 353                 -- Else loop
 354            else iteration us2 (iteration_no + 1) all_counts binds'
 355         }  } } }
 356       where
 357           (us1, us2) = splitUniqSupply us
 358 \end{code}