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