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 ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..),
  12                           SwitchResult(..), switchIsOn, intSwitchSet,
  13                           opt_D_dump_occur_anal, opt_D_dump_rules,
  14                           opt_D_dump_simpl_iterations,
  15                           opt_D_dump_simpl_stats,
  16                           opt_D_dump_simpl, opt_D_dump_rules,
  17                           opt_D_verbose_core2core,
  18                           opt_D_dump_occur_anal,
  19                           opt_UsageSPOn,
  20                         )
  21 import CoreLint         ( beginPass, endPass )
  22 import CoreTidy         ( tidyCorePgm )
  23 import CoreSyn
  24 import CSE              ( cseProgram )
  25 import Rules            ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
  26 import CoreUnfold
  27 import PprCore          ( pprCoreBindings )
  28 import OccurAnal        ( occurAnalyseBinds )
  29 import CoreUtils        ( exprIsTrivial, coreExprType )
  30 import Simplify         ( simplTopBinds, simplExpr )
  31 import SimplUtils       ( etaCoreExpr, findDefault, simplBinders )
  32 import SimplMonad
  33 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
  34 import ErrUtils         ( dumpIfSet )
  35 import FloatIn          ( floatInwards )
  36 import FloatOut         ( floatOutwards )
  37 import Id               ( Id, mkSysLocal, mkVanillaId, isBottomingId,
  38                           idType, setIdType, idName, idInfo, setIdNoDiscard
  39                         )
  40 import VarEnv
  41 import VarSet
  42 import Module           ( Module )
  43 import Name             ( mkLocalName, tidyOccName, tidyTopName,
  44                           NamedThing(..), OccName
  45                         )
  46 import TyCon            ( TyCon, isDataTyCon )
  47 import PrimOp           ( PrimOp(..) )
  48 import PrelInfo         ( unpackCStringId, unpackCString2Id, addr2IntegerId )
  49 import Type             ( Type, splitAlgTyConApp_maybe,
  50                           isUnLiftedType,
  51                           tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
  52                           Type
  53                         )
  54 import TysWiredIn       ( smallIntegerDataCon, isIntegerTy )
  55 import LiberateCase     ( liberateCase )
  56 import SAT              ( doStaticArgs )
  57 import Specialise       ( specProgram)
  58 import UsageSPInf       ( doUsageSPInf )
  59 import StrictAnal       ( saBinds )
  60 import WorkWrap         ( wwTopBinds )
  61 import CprAnalyse       ( cprAnalyse )
  62
  63 import Unique           ( Unique, Uniquable(..),
  64                           ratioTyConKey
  65                         )
  66 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
  67 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  68 import Util             ( mapAccumL )
  69 import SrcLoc           ( noSrcLoc )
  70 import Bag
  71 import Maybes
  72 import IO               ( hPutStr, stderr )
  73 import Outputable
  74
  75 import Ratio            ( numerator, denominator )
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{The driver for the simplifier}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
  86           -> [CoreBind]         -- Binds in
  87           -> [ProtoCoreRule]    -- Rules
  88           -> IO ([CoreBind], [ProtoCoreRule])
  89
  90 core2core core_todos binds rules
  91   = do
  92         us <-  mkSplitUniqSupply 's'
  93         let (cp_us, us1)   = splitUniqSupply us
  94             (ru_us, ps_us) = splitUniqSupply us1
  95
  96         better_rules <- simplRules ru_us rules binds
  97
  98         let (binds1, rule_base) = prepareRuleBase binds better_rules
  99
 100         -- Do the main business
 101         (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
 102                                                  rule_base core_todos
 103
 104         dumpIfSet opt_D_dump_simpl_stats
 105                   "Grand total simplifier statistics"
 106                   (pprSimplCount stats)
 107
 108         -- Do the post-simplification business
 109         post_simpl_binds <- doPostSimplification ps_us processed_binds
 110
 111         -- Return results
 112         return (post_simpl_binds, filter orphanRule better_rules)
 113
 114
 115 doCorePasses stats us binds irs []
 116   = return (stats, binds)
 117
 118 doCorePasses stats us binds irs (to_do : to_dos)
 119   = do
 120         let (us1, us2) =  splitUniqSupply us
 121         (stats1, binds1) <- doCorePass us1 binds irs to_do
 122         doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
 123
 124 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
 125 doCorePass us binds rb CoreCSE                  = _scc_ "CommonSubExpr" noStats (cseProgram binds)
 126 doCorePass us binds rb CoreLiberateCase         = _scc_ "LiberateCase"  noStats (liberateCase binds)
 127 doCorePass us binds rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
 128 doCorePass us binds rb CoreDoFullLaziness       = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
 129 doCorePass us binds rb CoreDoStaticArgs         = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
 130 doCorePass us binds rb CoreDoStrictness         = _scc_ "Stranal"       noStats (saBinds binds)
 131 doCorePass us binds rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
 132 doCorePass us binds rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
 133 doCorePass us binds rb CoreDoCPResult           = _scc_ "CPResult"      noStats (cprAnalyse binds)
 134 doCorePass us binds rb CoreDoPrintCore          = _scc_ "PrintCore"     noStats (printCore binds)
 135 doCorePass us binds rb CoreDoUSPInf
 136   = _scc_ "CoreUsageSPInf"
 137     if opt_UsageSPOn then
 138       noStats (doUsageSPInf us binds)
 139     else
 140       trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
 141       noStats (return binds)
 142
 143 printCore binds = do dumpIfSet True "Print Core"
 144                                (pprCoreBindings binds)
 145                      return binds
 146
 147 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
 148 \end{code}
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Dealing with rules}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 We must do some gentle simplifiation on the template (but not the RHS)
 158 of each rule.  The case that forced me to add this was the fold/build rule,
 159 which without simplification looked like:
 160         fold k z (build (/\a. g a))  ==>  ...
 161 This doesn't match unless you do eta reduction on the build argument.
 162
 163 \begin{code}
 164 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
 165 simplRules us rules binds
 166   = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
 167
 168         dumpIfSet opt_D_dump_rules
 169                   "Transformation rules"
 170                   (vcat (map pprProtoCoreRule better_rules))
 171
 172         return better_rules
 173   where
 174     black_list_all v = True             -- This stops all inlining
 175     sw_chkr any = SwBool False          -- A bit bogus
 176
 177         -- Boringly, we need to gather the in-scope set.
 178         -- Typically this thunk won't even be force, but the test in
 179         -- simpVar fails if it isn't right, and it might conceivably matter
 180     bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 181
 182
 183 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
 184   | not is_local
 185   = returnSmpl rule     -- No need to fiddle with imported rules
 186   | otherwise
 187   = simplBinders bndrs                  $ \ bndrs' ->
 188     mapSmpl simplExpr args              `thenSmpl` \ args' ->
 189     simplExpr rhs                       `thenSmpl` \ rhs' ->
 190     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsection{The driver for the simplifier}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 simplifyPgm :: RuleBase
 201             -> (SimplifierSwitch -> SwitchResult)
 202             -> UniqSupply
 203             -> [CoreBind]                               -- Input
 204             -> IO (SimplCount, [CoreBind])              -- New bindings
 205
 206 simplifyPgm (imported_rule_ids, rule_lhs_fvs)
 207             sw_chkr us binds
 208   = do {
 209         beginPass "Simplify";
 210
 211         -- Glom all binds together in one Rec, in case any
 212         -- transformations have introduced any new dependencies
 213         let { recd_binds = [Rec (flattenBinds binds)] };
 214
 215         (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
 216
 217         dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
 218                   "Simplifier statistics"
 219                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 220                          text "",
 221                          pprSimplCount counts_out]);
 222
 223         endPass "Simplify"
 224                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
 225                 binds' ;
 226
 227         return (counts_out, binds')
 228     }
 229   where
 230     max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 231     black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
 232
 233     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
 234                          | otherwise               = empty
 235
 236     iteration us iteration_no counts binds
 237       = do {
 238                 -- Occurrence analysis
 239            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 240
 241            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
 242                      (pprCoreBindings tagged_binds);
 243
 244                 -- Simplify
 245            let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
 246                                               black_list_fn
 247                                               (simplTopBinds tagged_binds);
 248                  all_counts        = counts `plusSimplCount` counts'
 249                } ;
 250
 251                 -- Stop if nothing happened; don't dump output
 252            if isZeroSimplCount counts' then
 253                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 254            else do {
 255
 256                 -- Dump the result of this iteration
 257            dumpIfSet opt_D_dump_simpl_iterations
 258                      ("Simplifier iteration " ++ show iteration_no
 259                       ++ " out of " ++ show max_iterations)
 260                      (pprSimplCount counts') ;
 261
 262            if opt_D_dump_simpl_iterations then
 263                 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
 264                         opt_D_verbose_core2core
 265                         binds'
 266            else
 267                 return [] ;
 268
 269                 -- Stop if we've run out of iterations
 270            if iteration_no == max_iterations then
 271                 do {
 272                     if  max_iterations > 2 then
 273                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 274                                     show max_iterations ++
 275                                     " iterations; bailing out.\n")
 276                     else return ();
 277
 278                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 279                 }
 280
 281                 -- Else loop
 282            else iteration us2 (iteration_no + 1) all_counts binds'
 283         }  }
 284       where
 285           (us1, us2) = splitUniqSupply us
 286 \end{code}
 287
 288
 289 %************************************************************************
 290 %*                                                                      *
 291 \subsection{PostSimplification}
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 Several tasks are performed by the post-simplification pass
 296
 297 1.  Make the representation of NoRep literals explicit, and
 298     float their bindings to the top level.  We only do the floating
 299     part for NoRep lits inside a lambda (else no gain).  We need to
 300     take care with      let x = "foo" in e
 301     that we don't end up with a silly binding
 302                         let x = y in e
 303     with a floated "foo".  What a bore.
 304
 305 4. Do eta reduction for lambda abstractions appearing in:
 306         - the RHS of case alternatives
 307         - the body of a let
 308
 309    These will otherwise turn into local bindings during Core->STG;
 310    better to nuke them if possible.  (In general the simplifier does
 311    eta expansion not eta reduction, up to this point.  It does eta
 312    on the RHSs of bindings but not the RHSs of case alternatives and
 313    let bodies)
 314
 315
 316 ------------------- NOT DONE ANY MORE ------------------------
 317 [March 98] Indirections are now elimianted by the occurrence analyser
 318 1.  Eliminate indirections.  The point here is to transform
 319         x_local = E
 320         x_exported = x_local
 321     ==>
 322         x_exported = E
 323
 324 [Dec 98] [Not now done because there is no penalty in the code
 325           generator for using the former form]
 326 2.  Convert
 327         case x of {...; x' -> ...x'...}
 328     ==>
 329         case x of {...; _  -> ...x... }
 330     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 331 --------------------------------------------------------------
 332
 333 Special case
 334 ~~~~~~~~~~~~
 335
 336 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
 337 things, and we need local Ids for non-floated stuff):
 338
 339   Don't float stuff out of a binder that's marked as a bottoming Id.
 340   Reason: it doesn't do any good, and creates more CAFs that increase
 341   the size of SRTs.
 342
 343 eg.
 344
 345         f = error "string"
 346
 347 is translated to
 348
 349         f' = unpackCString# "string"
 350         f = error f'
 351
 352 hence f' and f become CAFs.  Instead, the special case for
 353 tidyTopBinding below makes sure this comes out as
 354
 355         f = let f' = unpackCString# "string" in error f'
 356
 357 and we can safely ignore f as a CAF, since it can only ever be entered once.
 358
 359
 360
 361 \begin{code}
 362 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
 363 doPostSimplification us binds_in
 364   = do
 365         beginPass "Post-simplification pass"
 366         let binds_out = initPM us (postSimplTopBinds binds_in)
 367         endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
 368
 369 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
 370 postSimplTopBinds binds
 371   = mapPM postSimplTopBind binds        `thenPM` \ binds' ->
 372     returnPM (bagToList (unionManyBags binds'))
 373
 374 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
 375 postSimplTopBind (NonRec bndr rhs)
 376   | isBottomingId bndr          -- Don't lift out floats for bottoming Ids
 377                                 -- See notes above
 378   = getFloatsPM (postSimplExpr rhs)     `thenPM` \ (rhs', floats) ->
 379     returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
 380
 381 postSimplTopBind bind
 382   = getFloatsPM (postSimplBind bind)    `thenPM` \ (bind', floats) ->
 383     returnPM (floats `snocBag` bind')
 384
 385 postSimplBind (NonRec bndr rhs)
 386   = postSimplExpr rhs           `thenPM` \ rhs' ->
 387     returnPM (NonRec bndr rhs')
 388
 389 postSimplBind (Rec pairs)
 390   = mapPM postSimplExpr rhss    `thenPM` \ rhss' ->
 391     returnPM (Rec (bndrs `zip` rhss'))
 392   where
 393     (bndrs, rhss) = unzip pairs
 394 \end{code}
 395
 396
 397 Expressions
 398 ~~~~~~~~~~~
 399 \begin{code}
 400 postSimplExpr (Var v)   = returnPM (Var v)
 401 postSimplExpr (Type ty) = returnPM (Type ty)
 402
 403 postSimplExpr (App fun arg)
 404   = postSimplExpr fun   `thenPM` \ fun' ->
 405     postSimplExpr arg   `thenPM` \ arg' ->
 406     returnPM (App fun' arg')
 407
 408 postSimplExpr (Con (Literal lit) args)
 409   = ASSERT( null args )
 410     litToRep lit        `thenPM` \ (lit_ty, lit_expr) ->
 411     getInsideLambda     `thenPM` \ in_lam ->
 412     if in_lam && not (exprIsTrivial lit_expr) then
 413         -- It must have been a no-rep literal with a
 414         -- non-trivial representation; and we're inside a lambda;
 415         -- so float it to the top
 416         addTopFloat lit_ty lit_expr     `thenPM` \ v ->
 417         returnPM (Var v)
 418     else
 419         returnPM lit_expr
 420
 421 postSimplExpr (Con con args)
 422   = mapPM postSimplExpr args    `thenPM` \ args' ->
 423     returnPM (Con con args')
 424
 425 postSimplExpr (Lam bndr body)
 426   = insideLambda bndr           $
 427     postSimplExpr body          `thenPM` \ body' ->
 428     returnPM (Lam bndr body')
 429
 430 postSimplExpr (Let bind body)
 431   = postSimplBind bind          `thenPM` \ bind' ->
 432     postSimplExprEta body       `thenPM` \ body' ->
 433     returnPM (Let bind' body')
 434
 435 postSimplExpr (Note note body)
 436   = postSimplExprEta body       `thenPM` \ body' ->
 437     returnPM (Note note body')
 438
 439 postSimplExpr (Case scrut case_bndr alts)
 440   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 441     mapPM ps_alt alts                   `thenPM` \ alts' ->
 442     returnPM (Case scrut' case_bndr alts')
 443   where
 444     ps_alt (con,bndrs,rhs) = postSimplExprEta rhs       `thenPM` \ rhs' ->
 445                              returnPM (con, bndrs, rhs')
 446
 447 postSimplExprEta e = postSimplExpr e    `thenPM` \ e' ->
 448                      returnPM (etaCoreExpr e')
 449 \end{code}
 450
 451
 452 %************************************************************************
 453 %*                                                                      *
 454 \subsection[coreToStg-lits]{Converting literals}
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 Literals: the NoRep kind need to be de-no-rep'd.
 459 We always replace them with a simple variable, and float a suitable
 460 binding out to the top level.
 461
 462 \begin{code}
 463 litToRep :: Literal -> PostM (Type, CoreExpr)
 464
 465 litToRep (NoRepStr s ty)
 466   = returnPM (ty, rhs)
 467   where
 468     rhs = if (any is_NUL (_UNPK_ s))
 469
 470           then   -- Must cater for NULs in literal string
 471                 mkApps (Var unpackCString2Id)
 472                        [mkLit (MachStr s),
 473                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
 474
 475           else  -- No NULs in the string
 476                 App (Var unpackCStringId) (mkLit (MachStr s))
 477
 478     is_NUL c = c == '\0'
 479 \end{code}
 480
 481 If an Integer is small enough (Haskell implementations must support
 482 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 483 otherwise, wrap with @addr2Integer@.
 484
 485 \begin{code}
 486 litToRep (NoRepInteger i integer_ty)
 487   = returnPM (integer_ty, rhs)
 488   where
 489     rhs | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 490           i < tARGET_MAX_INT
 491         = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
 492
 493         | otherwise                     -- Big, so start from a string
 494         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
 495
 496
 497 litToRep (NoRepRational r rational_ty)
 498   = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))     `thenPM` \ num_arg ->
 499     postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))     `thenPM` \ denom_arg ->
 500     returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
 501   where
 502     (ratio_data_con, integer_ty)
 503       = case (splitAlgTyConApp_maybe rational_ty) of
 504           Just (tycon, [i_ty], [con])
 505             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
 506                (con, i_ty)
 507
 508           _ -> (panic "ratio_data_con", panic "integer_ty")
 509
 510 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection{The monad}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 type PostM a =  Bool                            -- True <=> inside a *value* lambda
 522              -> (UniqSupply, Bag CoreBind)      -- Unique supply and Floats in
 523              -> (a, (UniqSupply, Bag CoreBind))
 524
 525 initPM :: UniqSupply -> PostM a -> a
 526 initPM us m
 527   = case m False {- not inside lambda -} (us, emptyBag) of
 528         (result, _) -> result
 529
 530 returnPM v in_lam usf = (v, usf)
 531 thenPM m k in_lam usf = case m in_lam usf of
 532                                   (r, usf') -> k r in_lam usf'
 533
 534 mapPM f []     = returnPM []
 535 mapPM f (x:xs) = f x            `thenPM` \ r ->
 536                  mapPM f xs     `thenPM` \ rs ->
 537                  returnPM (r:rs)
 538
 539 insideLambda :: CoreBndr -> PostM a -> PostM a
 540 insideLambda bndr m in_lam usf | isId bndr = m True   usf
 541                                | otherwise = m in_lam usf
 542
 543 getInsideLambda :: PostM Bool
 544 getInsideLambda in_lam usf = (in_lam, usf)
 545
 546 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
 547 getFloatsPM m in_lam (us, floats)
 548   = let
 549         (a, (us', floats')) = m in_lam (us, emptyBag)
 550     in
 551     ((a, floats'), (us', floats))
 552
 553 addTopFloat :: Type -> CoreExpr -> PostM Id
 554 addTopFloat lit_ty lit_rhs in_lam (us, floats)
 555   = let
 556         (us1, us2) = splitUniqSupply us
 557         uniq       = uniqFromSupply us1
 558         lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
 559     in
 560     (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
 561 \end{code}
 562
 563