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