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