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