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