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, simplifyExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..),
  12                           SimplifierMode(..), DynFlags, DynFlag(..), dopt,
  13                           dopt_CoreToDo, buildCoreToDo
  14                         )
  15 import CoreSyn
  16 import TcIface          ( loadImportedRules )
  17 import HscTypes         ( HscEnv(..), ModGuts(..), ModGuts,
  18                           ModDetails(..), HomeModInfo(..) )
  19 import CSE              ( cseProgram )
  20 import Rules            ( RuleBase, ruleBaseIds,
  21                           extendRuleBaseList, pprRuleBase, getLocalRules,
  22                           ruleCheckProgram )
  23 import Module           ( moduleEnvElts )
  24 import PprCore          ( pprCoreBindings, pprCoreExpr, pprIdRules )
  25 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  26 import CoreUtils        ( coreBindsSize )
  27 import Simplify         ( simplTopBinds, simplExpr )
  28 import SimplUtils       ( simplBinders )
  29 import SimplMonad
  30 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  31 import CoreLint         ( endPass )
  32 import FloatIn          ( floatInwards )
  33 import FloatOut         ( floatOutwards )
  34 import Id               ( idIsFrom, idSpecialisation, setIdSpecialisation )
  35 import VarSet
  36 import LiberateCase     ( liberateCase )
  37 import SAT              ( doStaticArgs )
  38 import Specialise       ( specProgram)
  39 import SpecConstr       ( specConstrProgram)
  40 import DmdAnal          ( dmdAnalPgm )
  41 import WorkWrap         ( wwTopBinds )
  42 #ifdef OLD_STRICTNESS
  43 import StrictAnal       ( saBinds )
  44 import CprAnalyse       ( cprAnalyse )
  45 #endif
  46
  47 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  48 import IO               ( hPutStr, stderr )
  49 import Outputable
  50
  51 import Maybes           ( orElse )
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{The driver for the simplifier}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 core2core :: HscEnv
  62           -> ModGuts
  63           -> IO ModGuts
  64
  65 core2core hsc_env
  66           mod_impl@(ModGuts { mg_binds = binds_in })
  67   = do
  68         let dflags        = hsc_dflags hsc_env
  69             core_todos
  70                 | Just todo <- dopt_CoreToDo dflags  =  todo
  71                 | otherwise                          =  buildCoreToDo dflags
  72
  73         us <-  mkSplitUniqSupply 's'
  74         let (cp_us, ru_us) = splitUniqSupply us
  75
  76                 -- COMPUTE THE RULE BASE TO USE
  77         (rule_base, local_rule_ids, orphan_rules)
  78                 <- prepareRules hsc_env mod_impl ru_us
  79
  80                 -- PREPARE THE BINDINGS
  81         let binds1 = updateBinders local_rule_ids binds_in
  82
  83                 -- DO THE BUSINESS
  84         (stats, processed_binds)
  85                 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
  86
  87         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  88                   "Grand total simplifier statistics"
  89                   (pprSimplCount stats)
  90
  91         -- Return results
  92         -- We only return local orphan rules, i.e., local rules not attached to an Id
  93         -- The bindings cotain more rules, embedded in the Ids
  94         return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
  95
  96
  97 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
  98              -> CoreExpr
  99              -> IO CoreExpr
 100 -- simplifyExpr is called by the driver to simplify an
 101 -- expression typed in at the interactive prompt
 102 simplifyExpr dflags expr
 103   = do  {
 104         ; showPass dflags "Simplify"
 105
 106         ; us <-  mkSplitUniqSupply 's'
 107
 108         ; let env              = emptySimplEnv SimplGently [] emptyVarSet
 109               (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
 110
 111         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 112                         (pprCoreExpr expr')
 113
 114         ; return expr'
 115         }
 116
 117
 118 doCorePasses :: DynFlags
 119              -> RuleBase        -- the main rule base
 120              -> SimplCount      -- simplifier stats
 121              -> UniqSupply      -- uniques
 122              -> [CoreBind]      -- local binds in (with rules attached)
 123              -> [CoreToDo]      -- which passes to do
 124              -> IO (SimplCount, [CoreBind])  -- stats, binds, local orphan rules
 125
 126 doCorePasses dflags rb stats us binds []
 127   = return (stats, binds)
 128
 129 doCorePasses dflags rb stats us binds (to_do : to_dos)
 130   = do
 131         let (us1, us2) = splitUniqSupply us
 132
 133         (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
 134
 135         doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
 136
 137 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
 138    = _scc_ "Simplify"      simplifyPgm dfs rb mode switches us binds
 139 doCorePass dfs rb us binds CoreCSE
 140    = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
 141 doCorePass dfs rb us binds CoreLiberateCase
 142    = _scc_ "LiberateCase"  noStats dfs (liberateCase dfs binds)
 143 doCorePass dfs rb us binds CoreDoFloatInwards
 144    = _scc_ "FloatInwards"  noStats dfs (floatInwards dfs binds)
 145 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
 146    = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
 147 doCorePass dfs rb us binds CoreDoStaticArgs
 148    = _scc_ "StaticArgs"    noStats dfs (doStaticArgs us binds)
 149 doCorePass dfs rb us binds CoreDoStrictness
 150    = _scc_ "Stranal"       noStats dfs (dmdAnalPgm dfs binds)
 151 doCorePass dfs rb us binds CoreDoWorkerWrapper
 152    = _scc_ "WorkWrap"      noStats dfs (wwTopBinds dfs us binds)
 153 doCorePass dfs rb us binds CoreDoSpecialising
 154    = _scc_ "Specialise"    noStats dfs (specProgram dfs us binds)
 155 doCorePass dfs rb us binds CoreDoSpecConstr
 156    = _scc_ "SpecConstr"    noStats dfs (specConstrProgram dfs us binds)
 157 #ifdef OLD_STRICTNESS
 158 doCorePass dfs rb us binds CoreDoOldStrictness
 159    = _scc_ "OldStrictness"      noStats dfs (doOldStrictness dfs binds)
 160 #endif
 161 doCorePass dfs rb us binds CoreDoPrintCore
 162    = _scc_ "PrintCore"     noStats dfs (printCore binds)
 163 doCorePass dfs rb us binds CoreDoGlomBinds
 164    = noStats dfs (glomBinds dfs binds)
 165 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
 166    = noStats dfs (ruleCheck dfs phase pat binds)
 167 doCorePass dfs rb us binds CoreDoNothing
 168    = noStats dfs (return binds)
 169
 170 #ifdef OLD_STRICTNESS
 171 doOldStrictness dfs binds
 172   = do binds1 <- saBinds dfs binds
 173        binds2 <- cprAnalyse dfs binds1
 174        return binds2
 175 #endif
 176
 177 printCore binds = do dumpIfSet True "Print Core"
 178                                (pprCoreBindings binds)
 179                      return binds
 180
 181 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
 182                                       printDump (ruleCheckProgram phase pat binds)
 183                                       return binds
 184
 185 -- most passes return no stats and don't change rules
 186 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
 187
 188 \end{code}
 189
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection{Dealing with rules}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 199 -- It attaches those rules that are for local Ids to their binders, and
 200 -- returns the remainder attached to Ids in an IdSet.  It also returns
 201 -- Ids mentioned on LHS of some rule; these should be blacklisted.
 202
 203 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
 204 -- so that the opportunity to apply the rule isn't lost too soon
 205
 206 \begin{code}
 207 prepareRules :: HscEnv
 208              -> ModGuts
 209              -> UniqSupply
 210              -> IO (RuleBase,           -- Full rule base
 211                     IdSet,              -- Local rule Ids
 212                     [IdCoreRule])       -- Orphan rules defined in this module
 213
 214 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 215              guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
 216              us
 217   = do  { pkg_rule_base <- loadImportedRules hsc_env guts
 218
 219         ; let env              = emptySimplEnv SimplGently [] local_ids
 220               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 221
 222               imp_rule_base  = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
 223               full_rule_base = extendRuleBaseList imp_rule_base better_rules
 224
 225               (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
 226                 -- NB: the imported rules may include rules for Ids in this module
 227                 --     which is why we suck the local rules out of full_rule_base
 228
 229               orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
 230
 231         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 232                 (vcat [text "Local rules", pprIdRules better_rules,
 233                        text "",
 234                        text "Imported rules", pprRuleBase final_rule_base])
 235
 236         ; return (final_rule_base, local_rule_ids, orphan_rules)
 237     }
 238   where
 239     add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
 240
 241         -- Boringly, we need to gather the in-scope set.
 242     local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 243
 244
 245 updateBinders :: IdSet                  -- Locally defined ids with their Rules attached
 246               -> [CoreBind] -> [CoreBind]
 247         -- A horrible function
 248
 249 -- Update the binders of top-level bindings by
 250 -- attaching the rules for each locally-defined Id to that Id.
 251 --
 252 -- Reason
 253 --      - It makes the rules easier to look up
 254 --      - It means that transformation rules and specialisations for
 255 --        locally defined Ids are handled uniformly
 256 --      - It keeps alive things that are referred to only from a rule
 257 --        (the occurrence analyser knows about rules attached to Ids)
 258 --      - It makes sure that, when we apply a rule, the free vars
 259 --        of the RHS are more likely to be in scope
 260 --      - The imported rules are carried in the in-scope set
 261 --        which is extended on each iteration by the new wave of
 262 --        local binders; any rules which aren't on the binding will
 263 --        thereby get dropped
 264
 265 updateBinders rule_ids binds
 266   = map update_bndrs binds
 267   where
 268     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 269     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 270
 271     update_bndr bndr = case lookupVarSet rule_ids bndr of
 272                           Nothing -> bndr
 273                           Just id -> bndr `setIdSpecialisation` idSpecialisation id
 274 \end{code}
 275
 276
 277 We must do some gentle simplification on the template (but not the RHS)
 278 of each rule.  The case that forced me to add this was the fold/build rule,
 279 which without simplification looked like:
 280         fold k z (build (/\a. g a))  ==>  ...
 281 This doesn't match unless you do eta reduction on the build argument.
 282
 283 \begin{code}
 284 simplRule env rule@(id, BuiltinRule _ _)
 285   = returnSmpl rule
 286 simplRule env rule@(id, Rule act name bndrs args rhs)
 287   = simplBinders env bndrs              `thenSmpl` \ (env, bndrs') ->
 288     mapSmpl (simplExprGently env) args  `thenSmpl` \ args' ->
 289     simplExprGently env rhs             `thenSmpl` \ rhs' ->
 290     returnSmpl (id, Rule act name bndrs' args' rhs')
 291
 292 -- It's important that simplExprGently does eta reduction.
 293 -- For example, in a rule like:
 294 --      augment g (build h)
 295 -- we do not want to get
 296 --      augment (\a. g a) (build h)
 297 -- otherwise we don't match when given an argument like
 298 --      (\a. h a a)
 299 --
 300 -- The simplifier does indeed do eta reduction (it's in
 301 -- Simplify.completeLam) but only if -O is on.
 302 \end{code}
 303
 304 \begin{code}
 305 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 306 -- Simplifies an expression
 307 --      does occurrence analysis, then simplification
 308 --      and repeats (twice currently) because one pass
 309 --      alone leaves tons of crud.
 310 -- Used (a) for user expressions typed in at the interactive prompt
 311 --      (b) the LHS and RHS of a RULE
 312 --
 313 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 314 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 315 -- enforce that; it just simplifies the expression twice
 316
 317 simplExprGently env expr
 318   = simplExpr env (occurAnalyseGlobalExpr expr)         `thenSmpl` \ expr1 ->
 319     simplExpr env (occurAnalyseGlobalExpr expr1)
 320 \end{code}
 321
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsection{Glomming}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 \begin{code}
 330 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 331 -- Glom all binds together in one Rec, in case any
 332 -- transformations have introduced any new dependencies
 333 --
 334 -- NB: the global invariant is this:
 335 --      *** the top level bindings are never cloned, and are always unique ***
 336 --
 337 -- We sort them into dependency order, but applying transformation rules may
 338 -- make something at the top refer to something at the bottom:
 339 --      f = \x -> p (q x)
 340 --      h = \y -> 3
 341 --
 342 --      RULE:  p (q x) = h x
 343 --
 344 -- Applying this rule makes f refer to h,
 345 -- although it doesn't appear to in the source program.
 346 -- This pass lets us control where it happens.
 347 --
 348 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 349 -- function.  It only happens for rules whose head is an imported function
 350 -- (p in the example above).  So, for example, the rule had been
 351 --      RULE: f (p x) = h x
 352 -- then the rule for f would be attached to f itself (in its IdInfo)
 353 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 354 -- analyser as free in f.
 355
 356 glomBinds dflags binds
 357   = do { showPass dflags "GlomBinds" ;
 358          let { recd_binds = [Rec (flattenBinds binds)] } ;
 359          return recd_binds }
 360         -- Not much point in printing the result...
 361         -- just consumes output bandwidth
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{The driver for the simplifier}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 \begin{code}
 372 simplifyPgm :: DynFlags
 373             -> RuleBase
 374             -> SimplifierMode
 375             -> [SimplifierSwitch]
 376             -> UniqSupply
 377             -> [CoreBind]                   -- Input
 378             -> IO (SimplCount, [CoreBind])  -- New bindings
 379
 380 simplifyPgm dflags rule_base
 381             mode switches us binds
 382   = do {
 383         showPass dflags "Simplify";
 384
 385         (termination_msg, it_count, counts_out, binds')
 386            <- iteration us 1 (zeroSimplCount dflags) binds;
 387
 388         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 389                    && dopt Opt_D_dump_simpl_stats dflags)
 390                   "Simplifier statistics"
 391                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 392                          text "",
 393                          pprSimplCount counts_out]);
 394
 395         endPass dflags "Simplify" Opt_D_verbose_core2core binds';
 396
 397         return (counts_out, binds')
 398     }
 399   where
 400     phase_info        = case mode of
 401                           SimplGently  -> "gentle"
 402                           SimplPhase n -> show n
 403
 404     imported_rule_ids = ruleBaseIds rule_base
 405     simpl_env         = emptySimplEnv mode switches imported_rule_ids
 406     sw_chkr           = getSwitchChecker simpl_env
 407     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 408
 409     iteration us iteration_no counts binds
 410         -- iteration_no is the number of the iteration we are
 411         -- about to begin, with '1' for the first
 412       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 413       = do {
 414 #ifdef DEBUG
 415             if  max_iterations > 2 then
 416                 hPutStr stderr ("NOTE: Simplifier still going after " ++
 417                                 show max_iterations ++
 418                                 " iterations; bailing out.\n")
 419             else
 420                 return ();
 421 #endif
 422                 -- Subtract 1 from iteration_no to get the
 423                 -- number of iterations we actually completed
 424             return ("Simplifier baled out", iteration_no - 1, counts, binds)
 425         }
 426
 427       -- Try and force thunks off the binds; significantly reduces
 428       -- space usage, especially with -O.  JRS, 000620.
 429       | let sz = coreBindsSize binds in sz == sz
 430       = do {
 431                 -- Occurrence analysis
 432            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 433
 434            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 435                      (pprCoreBindings tagged_binds);
 436
 437                 -- SIMPLIFY
 438                 -- We do this with a *case* not a *let* because lazy pattern
 439                 -- matching bit us with bad space leak!
 440                 -- With a let, we ended up with
 441                 --   let
 442                 --      t = initSmpl ...
 443                 --      counts' = snd t
 444                 --   in
 445                 --      case t of {(_,counts') -> if counts'=0 then ... }
 446                 -- So the conditional didn't force counts', because the
 447                 -- selection got duplicated.  Sigh!
 448            case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
 449                 (binds', counts') -> do {
 450                         -- The imported_rule_ids are used by initSmpl to initialise
 451                         -- the in-scope set.  That way, the simplifier will change any
 452                         -- occurrences of the imported id to the one in the imported_rule_ids
 453                         -- set, which are decorated with their rules.
 454
 455            let { all_counts = counts `plusSimplCount` counts' ;
 456                  herald     = "Simplifier phase " ++ phase_info ++
 457                               ", iteration " ++ show iteration_no ++
 458                               " out of " ++ show max_iterations
 459                 } ;
 460
 461                 -- Stop if nothing happened; don't dump output
 462            if isZeroSimplCount counts' then
 463                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 464            else do {
 465
 466                 -- Dump the result of this iteration
 467            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 468                          (pprSimplCount counts') ;
 469
 470            endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 471
 472                 -- Loop
 473            iteration us2 (iteration_no + 1) all_counts binds'
 474         }  } } }
 475       where
 476           (us1, us2) = splitUniqSupply us
 477 \end{code}