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