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