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(..), ModGuts(..), ExternalPackageState(..),
  18                           ModDetails(..), HomeModInfo(..), hscEPS )
  19 import CSE              ( cseProgram )
  20 import Rules            ( RuleBase, ruleBaseIds, emptyRuleBase,
  21                           extendRuleBaseList, pprRuleBase, ruleCheckProgram )
  22 import Module           ( moduleEnvElts )
  23 import PprCore          ( pprCoreBindings, pprCoreExpr, pprIdRules )
  24 import OccurAnal        ( occurAnalyseBinds, occurAnalyseGlobalExpr )
  25 import CoreUtils        ( coreBindsSize )
  26 import Simplify         ( simplTopBinds, simplExpr )
  27 import SimplUtils       ( simplBinders )
  28 import SimplMonad
  29 import ErrUtils         ( dumpIfSet, dumpIfSet_dyn, showPass )
  30 import CoreLint         ( endPass )
  31 import VarEnv           ( mkInScopeSet )
  32 import FloatIn          ( floatInwards )
  33 import FloatOut         ( floatOutwards )
  34 import Id               ( idIsFrom, idSpecialisation, setIdSpecialisation )
  35 import VarSet
  36 import LiberateCase     ( liberateCase )
  37 import SAT              ( doStaticArgs )
  38 import Specialise       ( specProgram)
  39 import SpecConstr       ( specConstrProgram)
  40 import DmdAnal          ( dmdAnalPgm )
  41 import WorkWrap         ( wwTopBinds )
  42 #ifdef OLD_STRICTNESS
  43 import StrictAnal       ( saBinds )
  44 import CprAnalyse       ( cprAnalyse )
  45 #endif
  46
  47 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  48 import IO               ( hPutStr, stderr )
  49 import Outputable
  50 import List             ( partition )
  51 import Maybes           ( orElse )
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{The driver for the simplifier}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 core2core :: HscEnv
  62           -> ModGuts
  63           -> IO ModGuts
  64
  65 core2core hsc_env guts
  66   = do
  67         let dflags = hsc_dflags hsc_env
  68             core_todos
  69                 | Just todo <- dopt_CoreToDo dflags  =  todo
  70                 | otherwise                          =  buildCoreToDo dflags
  71
  72         us <- mkSplitUniqSupply 's'
  73         let (cp_us, ru_us) = splitUniqSupply us
  74
  75                 -- COMPUTE THE RULE BASE TO USE
  76         (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
  77
  78                 -- DO THE BUSINESS
  79         (stats, guts'') <- doCorePasses hsc_env cp_us
  80                                         (zeroSimplCount dflags)
  81                                         imp_rule_base guts' core_todos
  82
  83         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
  84                   "Grand total simplifier statistics"
  85                   (pprSimplCount stats)
  86
  87         return guts''
  88
  89
  90 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
  91              -> CoreExpr
  92              -> IO CoreExpr
  93 -- simplifyExpr is called by the driver to simplify an
  94 -- expression typed in at the interactive prompt
  95 simplifyExpr dflags expr
  96   = do  {
  97         ; showPass dflags "Simplify"
  98
  99         ; us <-  mkSplitUniqSupply 's'
 100
 101         ; let env              = emptySimplEnv SimplGently []
 102               (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
 103
 104         ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 105                         (pprCoreExpr expr')
 106
 107         ; return expr'
 108         }
 109
 110 doCorePasses :: HscEnv
 111              -> UniqSupply      -- uniques
 112              -> SimplCount      -- simplifier stats
 113              -> RuleBase        -- the main rule base
 114              -> ModGuts         -- local binds in (with rules attached)
 115              -> [CoreToDo]      -- which passes to do
 116              -> IO (SimplCount, ModGuts)
 117
 118 doCorePasses hsc_env us stats rb guts []
 119   = return (stats, guts)
 120
 121 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
 122   = do
 123         let (us1, us2) = splitUniqSupply us
 124         (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
 125         doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
 126
 127 doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
 128 doCorePass CoreCSE                     = _scc_ "CommonSubExpr" trBinds  cseProgram
 129 doCorePass CoreLiberateCase            = _scc_ "LiberateCase"  trBinds  liberateCase
 130 doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
 131 doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
 132 doCorePass CoreDoStaticArgs            = _scc_ "StaticArgs"    trBinds  doStaticArgs
 133 doCorePass CoreDoStrictness            = _scc_ "Stranal"       trBinds  dmdAnalPgm
 134 doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
 135 doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
 136 doCorePass CoreDoSpecConstr            = _scc_ "SpecConstr"    trBindsU specConstrProgram
 137 doCorePass CoreDoGlomBinds             = trBinds glomBinds
 138 doCorePass CoreDoPrintCore             = observe printCore
 139 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
 140 doCorePass CoreDoNothing               = observe (\ _ _ -> return ())
 141 #ifdef OLD_STRICTNESS
 142 doCorePass CoreDoOldStrictness         = _scc_ "OldStrictness" trBinds doOldStrictness
 143 #endif
 144
 145 #ifdef OLD_STRICTNESS
 146 doOldStrictness dfs binds
 147   = do binds1 <- saBinds dfs binds
 148        binds2 <- cprAnalyse dfs binds1
 149        return binds2
 150 #endif
 151
 152 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 153
 154 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
 155                                       printDump (ruleCheckProgram phase pat binds)
 156
 157 -- Most passes return no stats and don't change rules
 158 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 159         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 160         -> IO (SimplCount, RuleBase, ModGuts)
 161 trBinds do_pass hsc_env us rb guts
 162   = do  { binds' <- do_pass dflags (mg_binds guts)
 163         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 164   where
 165     dflags = hsc_dflags hsc_env
 166
 167 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
 168         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 169         -> IO (SimplCount, RuleBase, ModGuts)
 170 trBindsU do_pass hsc_env us rb guts
 171   = do  { binds' <- do_pass dflags us (mg_binds guts)
 172         ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
 173   where
 174     dflags = hsc_dflags hsc_env
 175
 176 -- Observer passes just peek; don't modify the bindings at all
 177 observe :: (DynFlags -> [CoreBind] -> IO a)
 178         -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
 179         -> IO (SimplCount, RuleBase, ModGuts)
 180 observe do_pass hsc_env us rb guts
 181   = do  { binds <- do_pass dflags (mg_binds guts)
 182         ; return (zeroSimplCount dflags, rb, guts) }
 183   where
 184     dflags = hsc_dflags hsc_env
 185 \end{code}
 186
 187
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection{Dealing with rules}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
 196 -- It attaches those rules that are for local Ids to their binders, and
 197 -- returns the remainder attached to Ids in an IdSet.
 198
 199 \begin{code}
 200 prepareRules :: HscEnv
 201              -> ModGuts
 202              -> UniqSupply
 203              -> IO (RuleBase,           -- Rule base for imported things, incl
 204                                         -- (a) rules defined in this module (orphans)
 205                                         -- (b) rules from other packages
 206                                         -- (c) rules from other modules in home package
 207                     ModGuts)            -- Modified fields are
 208                                         --      (a) Bindings have rules attached,
 209                                         --      (b) Rules are now just orphan rules
 210
 211 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 212              guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
 213              us
 214   = do  { eps <- hscEPS hsc_env
 215
 216         ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
 217                 -- from the local binders, to avoid warnings from Simplify.simplVar
 218               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 219               env              = setInScopeSet (emptySimplEnv SimplGently []) local_ids
 220               (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
 221
 222               (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
 223                 -- Get the rules for locally-defined Ids out of the RuleBase
 224                 -- If we miss any rules for Ids defined here, then we end up
 225                 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
 226                 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
 227                 -- and hence should be cloned), and now the binding for the class method
 228                 -- doesn't have the same Unique as the one in the Class and the tc-env
 229                 --      Example:        class Foo a where
 230                 --                        op :: a -> a
 231                 --                      {-# RULES "op" op x = x #-}
 232
 233                 -- NB: we assume that the imported rules dont include
 234                 --     rules for Ids in this module; if there is, the above bad things may happen
 235
 236               pkg_rule_base = eps_rule_base eps
 237               hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
 238               imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
 239
 240                 -- Update the binders in the local bindings with the lcoal rules
 241                 -- Update the binders of top-level bindings by
 242                 -- attaching the rules for each locally-defined Id to that Id.
 243                 --
 244                 -- Reason
 245                 --      - It makes the rules easier to look up
 246                 --      - It means that transformation rules and specialisations for
 247                 --        locally defined Ids are handled uniformly
 248                 --      - It keeps alive things that are referred to only from a rule
 249                 --        (the occurrence analyser knows about rules attached to Ids)
 250                 --      - It makes sure that, when we apply a rule, the free vars
 251                 --        of the RHS are more likely to be in scope
 252                 --      - The imported rules are carried in the in-scope set
 253                 --        which is extended on each iteration by the new wave of
 254                 --        local binders; any rules which aren't on the binding will
 255                 --        thereby get dropped
 256               local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
 257               binds_w_rules   = updateBinders local_rule_base binds
 258
 259         ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 260                 (vcat [text "Local rules", pprIdRules better_rules,
 261                        text "",
 262                        text "Imported rules", pprRuleBase imp_rule_base])
 263
 264 #ifdef DEBUG
 265         ; let bad_rules = filter (idIsFrom (mg_mod guts))
 266                                  (varSetElems (ruleBaseIds imp_rule_base))
 267         ; WARN( not (null bad_rules), ppr bad_rules ) return ()
 268 #endif
 269         ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
 270     }
 271   where
 272     add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
 273
 274 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
 275 updateBinders rule_base binds
 276   = map update_bndrs binds
 277   where
 278     rule_ids = ruleBaseIds rule_base
 279
 280     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
 281     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 282
 283     update_bndr bndr = case lookupVarSet rule_ids bndr of
 284                           Nothing -> bndr
 285                           Just id -> bndr `setIdSpecialisation` idSpecialisation id
 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 env rule@(IdCoreRule id _ (BuiltinRule _ _))
 297   = returnSmpl rule
 298 simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
 299   = simplBinders env bndrs              `thenSmpl` \ (env, bndrs') ->
 300     mapSmpl (simplExprGently env) args  `thenSmpl` \ args' ->
 301     simplExprGently env rhs             `thenSmpl` \ rhs' ->
 302     returnSmpl (IdCoreRule id is_orph (Rule act 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 :: SimplEnv -> 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 --
 325 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 326 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 327 -- enforce that; it just simplifies the expression twice
 328
 329 simplExprGently env expr
 330   = simplExpr env (occurAnalyseGlobalExpr expr)         `thenSmpl` \ expr1 ->
 331     simplExpr env (occurAnalyseGlobalExpr expr1)
 332 \end{code}
 333
 334
 335 %************************************************************************
 336 %*                                                                      *
 337 \subsection{Glomming}
 338 %*                                                                      *
 339 %************************************************************************
 340
 341 \begin{code}
 342 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 343 -- Glom all binds together in one Rec, in case any
 344 -- transformations have introduced any new dependencies
 345 --
 346 -- NB: the global invariant is this:
 347 --      *** the top level bindings are never cloned, and are always unique ***
 348 --
 349 -- We sort them into dependency order, but applying transformation rules may
 350 -- make something at the top refer to something at the bottom:
 351 --      f = \x -> p (q x)
 352 --      h = \y -> 3
 353 --
 354 --      RULE:  p (q x) = h x
 355 --
 356 -- Applying this rule makes f refer to h,
 357 -- although it doesn't appear to in the source program.
 358 -- This pass lets us control where it happens.
 359 --
 360 -- NOTICE that this cannot happen for rules whose head is a locally-defined
 361 -- function.  It only happens for rules whose head is an imported function
 362 -- (p in the example above).  So, for example, the rule had been
 363 --      RULE: f (p x) = h x
 364 -- then the rule for f would be attached to f itself (in its IdInfo)
 365 -- by prepareLocalRuleBase and h would be regarded by the occurrency
 366 -- analyser as free in f.
 367
 368 glomBinds dflags binds
 369   = do { showPass dflags "GlomBinds" ;
 370          let { recd_binds = [Rec (flattenBinds binds)] } ;
 371          return recd_binds }
 372         -- Not much point in printing the result...
 373         -- just consumes output bandwidth
 374 \end{code}
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection{The driver for the simplifier}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 simplifyPgm :: SimplifierMode
 385             -> [SimplifierSwitch]
 386             -> HscEnv
 387             -> UniqSupply
 388             -> RuleBase
 389             -> ModGuts
 390             -> IO (SimplCount, RuleBase, ModGuts)  -- New bindings
 391
 392 simplifyPgm mode switches hsc_env us rule_base guts
 393   = do {
 394         showPass dflags "Simplify";
 395
 396         (termination_msg, it_count, counts_out, rule_base', guts')
 397            <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
 398
 399         dumpIfSet (dopt Opt_D_verbose_core2core dflags
 400                    && dopt Opt_D_dump_simpl_stats dflags)
 401                   "Simplifier statistics"
 402                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 403                          text "",
 404                          pprSimplCount counts_out]);
 405
 406         endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
 407
 408         return (counts_out, rule_base', guts')
 409     }
 410   where
 411     dflags            = hsc_dflags hsc_env
 412     phase_info        = case mode of
 413                           SimplGently  -> "gentle"
 414                           SimplPhase n -> show n
 415
 416     simpl_env         = emptySimplEnv mode switches
 417     sw_chkr           = getSwitchChecker simpl_env
 418     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
 419
 420     do_iteration us rule_base iteration_no counts guts
 421         -- iteration_no is the number of the iteration we are
 422         -- about to begin, with '1' for the first
 423       | iteration_no > max_iterations   -- Stop if we've run out of iterations
 424       = do {
 425 #ifdef DEBUG
 426             if  max_iterations > 2 then
 427                 hPutStr stderr ("NOTE: Simplifier still going after " ++
 428                                 show max_iterations ++
 429                                 " iterations; bailing out.\n")
 430             else
 431                 return ();
 432 #endif
 433                 -- Subtract 1 from iteration_no to get the
 434                 -- number of iterations we actually completed
 435             return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
 436         }
 437
 438       -- Try and force thunks off the binds; significantly reduces
 439       -- space usage, especially with -O.  JRS, 000620.
 440       | let sz = coreBindsSize (mg_binds guts) in sz == sz
 441       = do {
 442                 -- Occurrence analysis
 443            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
 444
 445            dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 446                      (pprCoreBindings tagged_binds);
 447
 448                 -- Get any new rules, and extend the rule base
 449                 -- (on the side this extends the package rule base in the
 450                 --  ExternalPackageTable, ready for the next complation
 451                 --  in --make mode)
 452                 -- We need to do this regularly, because simplification can
 453                 -- poke on IdInfo thunks, which in turn brings in new rules
 454                 -- behind the scenes.  Otherwise there's a danger we'll simply
 455                 -- miss the rules for Ids hidden inside imported inlinings
 456            new_rules <- loadImportedRules hsc_env guts ;
 457            let  { rule_base' = extendRuleBaseList rule_base new_rules
 458                 ; in_scope   = mkInScopeSet (ruleBaseIds rule_base')
 459                 ; simpl_env' = setInScopeSet simpl_env in_scope } ;
 460                         -- The new rule base Ids are used to initialise
 461                         -- the in-scope set.  That way, the simplifier will change any
 462                         -- occurrences of the imported id to the one in the imported_rule_ids
 463                         -- set, which are decorated with their rules.
 464
 465                 -- Simplify the program
 466                 -- We do this with a *case* not a *let* because lazy pattern
 467                 -- matching bit us with bad space leak!
 468                 -- With a let, we ended up with
 469                 --   let
 470                 --      t = initSmpl ...
 471                 --      counts' = snd t
 472                 --   in
 473                 --      case t of {(_,counts') -> if counts'=0 then ... }
 474                 -- So the conditional didn't force counts', because the
 475                 -- selection got duplicated.  Sigh!
 476            case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of {
 477                 (binds', counts') -> do {
 478
 479            let  { guts'      = guts { mg_binds = binds' }
 480                 ; all_counts = counts `plusSimplCount` counts'
 481                 ; herald     = "Simplifier phase " ++ phase_info ++
 482                               ", iteration " ++ show iteration_no ++
 483                               " out of " ++ show max_iterations
 484                 } ;
 485
 486                 -- Stop if nothing happened; don't dump output
 487            if isZeroSimplCount counts' then
 488                 return ("Simplifier reached fixed point", iteration_no,
 489                         all_counts, rule_base', guts')
 490            else do {
 491
 492                 -- Dump the result of this iteration
 493            dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 494                          (pprSimplCount counts') ;
 495
 496            endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 497
 498                 -- Loop
 499            do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
 500         }  } } }
 501       where
 502           (us1, us2) = splitUniqSupply us
 503 \end{code}