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