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