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