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