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,
  13                           opt_D_dump_occur_anal,
  14                           opt_D_dump_simpl_iterations,
  15                           opt_D_simplifier_stats,
  16                           opt_D_dump_simpl,
  17                           opt_D_verbose_core2core,
  18                           opt_D_dump_occur_anal
  19                         )
  20 import CoreLint         ( beginPass, endPass )
  21 import CoreSyn
  22 import PprCore          ( pprCoreBindings )
  23 import OccurAnal        ( occurAnalyseBinds )
  24 import CoreUtils        ( exprIsTrivial, coreExprType )
  25 import Simplify         ( simplBind )
  26 import SimplUtils       ( etaCoreExpr, findDefault )
  27 import SimplMonad
  28 import CoreUnfold
  29 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
  30 import ErrUtils         ( dumpIfSet )
  31 import FloatIn          ( floatInwards )
  32 import FloatOut         ( floatOutwards )
  33 import Id               ( Id, mkSysLocal, mkUserId, isBottomingId,
  34                           idType, setIdType, idName, idInfo, idDetails
  35                         )
  36 import IdInfo           ( InlinePragInfo(..), specInfo, setSpecInfo,
  37                           inlinePragInfo, setInlinePragInfo,
  38                           setUnfoldingInfo
  39                         )
  40 import VarEnv
  41 import VarSet
  42 import Module           ( Module )
  43 import Name             ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
  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 Class            ( Class, classSelIds )
  55 import TysWiredIn       ( smallIntegerDataCon, isIntegerTy )
  56 import LiberateCase     ( liberateCase )
  57 import SAT              ( doStaticArgs )
  58 import Specialise       ( specProgram)
  59 import SpecEnv          ( specEnvToList, specEnvFromList )
  60 import StrictAnal       ( saBinds )
  61 import WorkWrap         ( wwTopBinds )
  62 import CprAnalyse       ( cprAnalyse )
  63
  64 import Var              ( TyVar, mkId )
  65 import Unique           ( Unique, Uniquable(..),
  66                           ratioTyConKey, mkUnique, incrUnique, initTidyUniques
  67                         )
  68 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply )
  69 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  70 import Util             ( mapAccumL )
  71 import SrcLoc           ( noSrcLoc )
  72 import Bag
  73 import Maybes
  74 import IO               ( hPutStr, stderr )
  75 import Outputable
  76
  77 import Ratio            ( numerator, denominator )
  78 \end{code}
  79
  80 \begin{code}
  81 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
  82           -> Module             -- Module name (profiling only)
  83           -> [Class]            -- Local classes
  84           -> UniqSupply         -- A name supply
  85           -> [CoreBind]         -- Input
  86           -> IO [CoreBind]      -- Result
  87
  88 core2core core_todos module_name classes us binds
  89   = do
  90         let (us1, us2) = splitUniqSupply us
  91
  92         -- Do the main business
  93         processed_binds <- doCorePasses us1 binds core_todos
  94
  95         -- Do the post-simplification business
  96         post_simpl_binds <- doPostSimplification us2 processed_binds
  97
  98         -- Do the final tidy-up
  99         final_binds <- tidyCorePgm module_name classes post_simpl_binds
 100
 101         -- Return results
 102         return final_binds
 103
 104 doCorePasses us binds []
 105   = return binds
 106
 107 doCorePasses us binds (to_do : to_dos)
 108   = do
 109         let (us1, us2) =  splitUniqSupply us
 110         binds1         <- doCorePass us1 binds to_do
 111         doCorePasses us2 binds1 to_dos
 112
 113 doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify"       simplifyPgm sw_chkr us binds
 114 doCorePass us binds CoreLiberateCase         = _scc_ "LiberateCase"   liberateCase binds
 115 doCorePass us binds CoreDoFloatInwards       = _scc_ "FloatInwards"   floatInwards binds
 116 doCorePass us binds CoreDoFullLaziness       = _scc_ "CoreFloating"   floatOutwards us binds
 117 doCorePass us binds CoreDoStaticArgs         = _scc_ "CoreStaticArgs" doStaticArgs us binds
 118 doCorePass us binds CoreDoStrictness         = _scc_ "CoreStranal"    saBinds binds
 119 doCorePass us binds CoreDoWorkerWrapper      = _scc_ "CoreWorkWrap"   wwTopBinds us binds
 120 doCorePass us binds CoreDoSpecialising       = _scc_ "Specialise"     specProgram us binds
 121 doCorePass us binds CoreDoCPResult           = _scc_ "CPResult"       cprAnalyse binds
 122 doCorePass us binds CoreDoPrintCore          = _scc_ "PrintCore"      do
 123                                                                        putStr (showSDoc $ pprCoreBindings binds)
 124                                                                        return binds
 125 \end{code}
 126
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection{The driver for the simplifier}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 simplifyPgm :: (SimplifierSwitch -> SwitchResult)
 136             -> UniqSupply
 137             -> [CoreBind]               -- Input
 138             -> IO [CoreBind]            -- New bindings
 139
 140 simplifyPgm sw_chkr us binds
 141   = do {
 142         beginPass "Simplify";
 143
 144         (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
 145
 146         dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
 147                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 148                          text "",
 149                          pprSimplCount counts]);
 150
 151         endPass "Simplify"
 152                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
 153                 binds'
 154     }
 155   where
 156     max_iterations      = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 157     simpl_switch_is_on  = switchIsOn sw_chkr
 158
 159     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
 160                          | otherwise               = empty
 161
 162     iteration us iteration_no counts binds
 163       = do {
 164                 -- Occurrence analysis
 165            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
 166            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
 167                      (pprCoreBindings tagged_binds);
 168
 169                 -- Simplify
 170            let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
 171                  all_counts        = counts `plusSimplCount` counts'
 172                } ;
 173
 174                 -- Stop if nothing happened; don't dump output
 175            if isZeroSimplCount counts' then
 176                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 177            else do {
 178
 179                 -- Dump the result of this iteration
 180            dumpIfSet opt_D_dump_simpl_iterations
 181                      ("Simplifier iteration " ++ show iteration_no
 182                       ++ " out of " ++ show max_iterations)
 183                      (vcat[pprSimplCount counts',
 184                            text "",
 185                            core_iter_dump binds']) ;
 186
 187                 -- Stop if we've run out of iterations
 188            if iteration_no == max_iterations then
 189                 do {
 190                     if  max_iterations > 1 then
 191                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 192                                     show max_iterations ++
 193                                     " iterations; bailing out.\n")
 194                     else return ();
 195
 196                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 197                 }
 198
 199                 -- Else loop
 200            else iteration us2 (iteration_no + 1) all_counts binds'
 201         }  }
 202       where
 203           (us1, us2) = splitUniqSupply us
 204
 205
 206 simplTopBinds binds = go binds          `thenSmpl` \ (binds', _) ->
 207                       returnSmpl binds'
 208                     where
 209                       go []              = returnSmpl ([], ())
 210                       go (bind1 : binds) = simplBind bind1 (go binds)
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Tidying core}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 Several tasks are done by @tidyCorePgm@
 221
 222 1.  Make certain top-level bindings into Globals. The point is that
 223     Global things get externally-visible labels at code generation
 224     time
 225
 226
 227 2. Give all binders a nice print-name.  Their uniques aren't changed;
 228    rather we give them lexically unique occ-names, so that we can
 229    safely print the OccNae only in the interface file.  [Bad idea to
 230    change the uniques, because the code generator makes global labels
 231    from the uniques for local thunks etc.]
 232
 233
 234 \begin{code}
 235 tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
 236 tidyCorePgm mod local_classes binds_in
 237   = do
 238         beginPass "Tidy Core"
 239         let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
 240         endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
 241   where
 242         -- Make sure to avoid the names of class operations
 243         -- They don't have top-level bindings, so we won't see them
 244         -- in binds_in; so we must initialise the tidy_env appropriately
 245         --
 246         -- We also make sure to avoid any exported binders.  Consider
 247         --      f{-u1-} = 1     -- Local decl
 248         --      ...
 249         --      f{-u2-} = 2     -- Exported decl
 250         --
 251         -- The second exported decl must 'get' the name 'f', so we
 252         -- have to put 'f' in the avoids list before we get to the first
 253         -- decl.  Name.tidyName then does a no-op on exported binders.
 254     init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
 255     avoids        = [getOccName sel_id | cls <- local_classes,
 256                                          sel_id <- classSelIds cls]
 257                     ++
 258                     [getOccName bndr | bind <- binds_in,
 259                                        bndr <- bindersOf bind,
 260                                        isExported bndr]
 261
 262 tidyBind :: Maybe Module                -- (Just m) for top level, Nothing for nested
 263          -> TidyEnv
 264          -> CoreBind
 265          -> (TidyEnv, CoreBind)
 266 tidyBind maybe_mod env (NonRec bndr rhs)
 267   = let
 268         (env', bndr') = tidyBndr maybe_mod env bndr
 269         rhs'          = tidyExpr env rhs
 270     in
 271     (env', NonRec bndr' rhs')
 272
 273 tidyBind maybe_mod env (Rec pairs)
 274   = let
 275         -- We use env' when tidying the rhss
 276         -- When tidying the binder itself we may tidy it's
 277         -- specialisations; if any of these mention other binders
 278         -- in the group we should really feed env' to them too;
 279         -- but that seems (a) unlikely and (b) a bit tiresome.
 280         -- So I left it out for now
 281
 282         (bndrs, rhss)  = unzip pairs
 283         (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
 284         rhss'          = map (tidyExpr env') rhss
 285   in
 286   (env', Rec (zip bndrs' rhss'))
 287
 288 tidyExpr env (Type ty)       = Type (tidyType env ty)
 289 tidyExpr env (Con con args)  = Con con (map (tidyExpr env) args)
 290 tidyExpr env (App f a)       = App (tidyExpr env f) (tidyExpr env a)
 291 tidyExpr env (Note n e)      = Note (tidyNote env n) (tidyExpr env e)
 292
 293 tidyExpr env (Let b e)       = Let b' (tidyExpr env' e)
 294                              where
 295                                (env', b') = tidyBind Nothing env b
 296
 297 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
 298                              where
 299                                (env', b') = tidyNestedBndr env b
 300
 301 tidyExpr env (Var v)         = case lookupVarEnv var_env v of
 302                                   Just v' -> Var v'
 303                                   Nothing -> Var v
 304                              where
 305                                (_, var_env) = env
 306
 307 tidyExpr env (Lam b e)       = Lam b' (tidyExpr env' e)
 308                              where
 309                                (env', b') = tidyNestedBndr env b
 310
 311 tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
 312                              where
 313                                (env', vs') = mapAccumL tidyNestedBndr env vs
 314
 315 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 316
 317 tidyNote env note            = note
 318 \end{code}
 319
 320 \begin{code}
 321 tidyBndr (Just mod) env id  = tidyTopBndr mod env id
 322 tidyBndr Nothing    env var = tidyNestedBndr  env var
 323
 324 tidyNestedBndr env tyvar
 325   | isTyVar tyvar
 326   = tidyTyVar env tyvar
 327
 328 tidyNestedBndr env@(tidy_env, var_env) id
 329   =     -- Non-top-level variables
 330     let
 331         -- Give the Id a fresh print-name, *and* rename its type
 332         -- The SrcLoc isn't important now, though we could extract it from the Id
 333         name'             = mkLocalName (getUnique id) occ' noSrcLoc
 334         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 335         ty'               = tidyType env (idType id)
 336         id'               = mkUserId name' ty'
 337                         -- NB: This throws away the IdInfo of the Id, which we
 338                         -- no longer need.  That means we don't need to
 339                         -- run over it with env, nor renumber it.
 340         var_env'          = extendVarEnv var_env id id'
 341     in
 342     ((tidy_env', var_env'), id')
 343
 344 tidyTopBndr mod env@(tidy_env, var_env) id
 345   =     -- Top level variables
 346     let
 347         (tidy_env', name') = tidyTopName mod tidy_env (idName id)
 348         ty'                = tidyTopType (idType id)
 349         idinfo'            = tidyIdInfo env (idInfo id)
 350         id'                = mkId name' ty' (idDetails id) idinfo'
 351         var_env'           = extendVarEnv var_env id id'
 352     in
 353     ((tidy_env', var_env'), id')
 354
 355 -- tidyIdInfo does these things:
 356 --      a) tidy the specialisation info (if any)
 357 --      b) zap a complicated ICanSafelyBeINLINEd pragma,
 358 --      c) zap the unfolding
 359 -- The latter two are to avoid space leaks
 360
 361 tidyIdInfo env info
 362   = info3
 363   where
 364     spec_items = specEnvToList (specInfo info)
 365     spec_env'  = specEnvFromList (map tidy_item spec_items)
 366     info1 | null spec_items = info
 367           | otherwise       = spec_env' `setSpecInfo` info
 368
 369     info2 = case inlinePragInfo info of
 370                 ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
 371                 other                   -> info1
 372
 373     info3 = noUnfolding `setUnfoldingInfo` info2
 374
 375     tidy_item (tyvars, tys, rhs)
 376         = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)
 377         where
 378           (env', tyvars') = tidyTyVars env tyvars
 379 \end{code}
 380
 381
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection{PostSimplification}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 Several tasks are performed by the post-simplification pass
 390
 391 1.  Make the representation of NoRep literals explicit, and
 392     float their bindings to the top level.  We only do the floating
 393     part for NoRep lits inside a lambda (else no gain).  We need to
 394     take care with      let x = "foo" in e
 395     that we don't end up with a silly binding
 396                         let x = y in e
 397     with a floated "foo".  What a bore.
 398
 399 2.  *Mangle* cases involving par# in the discriminant.  The unfolding
 400     for par in PrelConc.lhs include case expressions with integer
 401     results solely to fool the strictness analyzer, the simplifier,
 402     and anyone else who might want to fool with the evaluation order.
 403     At this point in the compiler our evaluation order is safe.
 404     Therefore, we convert expressions of the form:
 405
 406         case par# e of
 407           0# -> rhs
 408           _  -> parError#
 409     ==>
 410         case par# e of
 411           _ -> rhs
 412
 413     fork# isn't handled like this - it's an explicit IO operation now.
 414     The reason is that fork# returns a ThreadId#, which gets in the
 415     way of the above scheme.  And anyway, IO is the only guaranteed
 416     way to enforce ordering  --SDM.
 417
 418 3.  Mangle cases involving seq# in the discriminant.  Up to this
 419     point, seq# will appear like this:
 420
 421           case seq# e of
 422                 0# -> seqError#
 423                 _  -> ...
 424
 425     where the 0# branch is purely to bamboozle the strictness analyser
 426     (see case 4 above).  This code comes from an unfolding for 'seq'
 427     in Prelude.hs.  We translate this into
 428
 429           case e of
 430                 _ -> ...
 431
 432     Now that the evaluation order is safe.
 433
 434 4. Do eta reduction for lambda abstractions appearing in:
 435         - the RHS of case alternatives
 436         - the body of a let
 437
 438    These will otherwise turn into local bindings during Core->STG;
 439    better to nuke them if possible.  (In general the simplifier does
 440    eta expansion not eta reduction, up to this point.  It does eta
 441    on the RHSs of bindings but not the RHSs of case alternatives and
 442    let bodies)
 443
 444
 445 ------------------- NOT DONE ANY MORE ------------------------
 446 [March 98] Indirections are now elimianted by the occurrence analyser
 447 1.  Eliminate indirections.  The point here is to transform
 448         x_local = E
 449         x_exported = x_local
 450     ==>
 451         x_exported = E
 452
 453 [Dec 98] [Not now done because there is no penalty in the code
 454           generator for using the former form]
 455 2.  Convert
 456         case x of {...; x' -> ...x'...}
 457     ==>
 458         case x of {...; _  -> ...x... }
 459     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 460 --------------------------------------------------------------
 461
 462 Special case
 463 ~~~~~~~~~~~~
 464
 465 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
 466 things, and we need local Ids for non-floated stuff):
 467
 468   Don't float stuff out of a binder that's marked as a bottoming Id.
 469   Reason: it doesn't do any good, and creates more CAFs that increase
 470   the size of SRTs.
 471
 472 eg.
 473
 474         f = error "string"
 475
 476 is translated to
 477
 478         f' = unpackCString# "string"
 479         f = error f'
 480
 481 hence f' and f become CAFs.  Instead, the special case for
 482 tidyTopBinding below makes sure this comes out as
 483
 484         f = let f' = unpackCString# "string" in error f'
 485
 486 and we can safely ignore f as a CAF, since it can only ever be entered once.
 487
 488
 489
 490 \begin{code}
 491 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
 492 doPostSimplification us binds_in
 493   = do
 494         beginPass "Post-simplification pass"
 495         let binds_out = initPM us (postSimplTopBinds binds_in)
 496         endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
 497
 498 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
 499 postSimplTopBinds binds
 500   = mapPM postSimplTopBind binds        `thenPM` \ binds' ->
 501     returnPM (bagToList (unionManyBags binds'))
 502
 503 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
 504 postSimplTopBind (NonRec bndr rhs)
 505   | isBottomingId bndr          -- Don't lift out floats for bottoming Ids
 506                                 -- See notes above
 507   = getFloatsPM (postSimplExpr rhs)     `thenPM` \ (rhs', floats) ->
 508     returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
 509
 510 postSimplTopBind bind
 511   = getFloatsPM (postSimplBind bind)    `thenPM` \ (bind', floats) ->
 512     returnPM (floats `snocBag` bind')
 513
 514 postSimplBind (NonRec bndr rhs)
 515   = postSimplExpr rhs           `thenPM` \ rhs' ->
 516     returnPM (NonRec bndr rhs')
 517
 518 postSimplBind (Rec pairs)
 519   = mapPM postSimplExpr rhss    `thenPM` \ rhss' ->
 520     returnPM (Rec (bndrs `zip` rhss'))
 521   where
 522     (bndrs, rhss) = unzip pairs
 523 \end{code}
 524
 525
 526 Expressions
 527 ~~~~~~~~~~~
 528 \begin{code}
 529 postSimplExpr (Var v)   = returnPM (Var v)
 530 postSimplExpr (Type ty) = returnPM (Type ty)
 531
 532 postSimplExpr (App fun arg)
 533   = postSimplExpr fun   `thenPM` \ fun' ->
 534     postSimplExpr arg   `thenPM` \ arg' ->
 535     returnPM (App fun' arg')
 536
 537 postSimplExpr (Con (Literal lit) args)
 538   = ASSERT( null args )
 539     litToRep lit        `thenPM` \ (lit_ty, lit_expr) ->
 540     getInsideLambda     `thenPM` \ in_lam ->
 541     if in_lam && not (exprIsTrivial lit_expr) then
 542         -- It must have been a no-rep literal with a
 543         -- non-trivial representation; and we're inside a lambda;
 544         -- so float it to the top
 545         addTopFloat lit_ty lit_expr     `thenPM` \ v ->
 546         returnPM (Var v)
 547     else
 548         returnPM lit_expr
 549
 550 postSimplExpr (Con con args)
 551   = mapPM postSimplExpr args    `thenPM` \ args' ->
 552     returnPM (Con con args')
 553
 554 postSimplExpr (Lam bndr body)
 555   = insideLambda bndr           $
 556     postSimplExpr body          `thenPM` \ body' ->
 557     returnPM (Lam bndr body')
 558
 559 postSimplExpr (Let bind body)
 560   = postSimplBind bind          `thenPM` \ bind' ->
 561     postSimplExprEta body       `thenPM` \ body' ->
 562     returnPM (Let bind' body')
 563
 564 postSimplExpr (Note note body)
 565   = postSimplExprEta body       `thenPM` \ body' ->
 566     returnPM (Note note body')
 567
 568 -- seq#: see notes above.
 569 -- NB: seq# :: forall a. a -> Int#
 570 postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
 571   = postSimplExpr e                     `thenPM` \ e' ->
 572     let
 573         -- The old binder can't have been used, so we
 574         -- can gaily re-use it (yuk!)
 575         new_bndr = setIdType bndr ty
 576     in
 577     postSimplExprEta default_rhs        `thenPM` \ rhs' ->
 578     returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
 579   where
 580     (other_alts, maybe_default)  = findDefault alts
 581     Just default_rhs             = maybe_default
 582
 583 -- par#: see notes above.
 584 postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
 585   | funnyParallelOp op && maybeToBool maybe_default
 586   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 587     postSimplExprEta default_rhs        `thenPM` \ rhs' ->
 588     returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
 589   where
 590     (other_alts, maybe_default)  = findDefault alts
 591     Just default_rhs             = maybe_default
 592
 593 postSimplExpr (Case scrut case_bndr alts)
 594   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 595     mapPM ps_alt alts                   `thenPM` \ alts' ->
 596     returnPM (Case scrut' case_bndr alts')
 597   where
 598     ps_alt (con,bndrs,rhs) = postSimplExprEta rhs       `thenPM` \ rhs' ->
 599                              returnPM (con, bndrs, rhs')
 600
 601 postSimplExprEta e = postSimplExpr e    `thenPM` \ e' ->
 602                      returnPM (etaCoreExpr e')
 603 \end{code}
 604
 605 \begin{code}
 606 funnyParallelOp ParOp  = True
 607 funnyParallelOp _      = False
 608 \end{code}
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613 \subsection[coreToStg-lits]{Converting literals}
 614 %*                                                                      *
 615 %************************************************************************
 616
 617 Literals: the NoRep kind need to be de-no-rep'd.
 618 We always replace them with a simple variable, and float a suitable
 619 binding out to the top level.
 620
 621 \begin{code}
 622 litToRep :: Literal -> PostM (Type, CoreExpr)
 623
 624 litToRep (NoRepStr s ty)
 625   = returnPM (ty, rhs)
 626   where
 627     rhs = if (any is_NUL (_UNPK_ s))
 628
 629           then   -- Must cater for NULs in literal string
 630                 mkApps (Var unpackCString2Id)
 631                        [mkLit (MachStr s),
 632                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
 633
 634           else  -- No NULs in the string
 635                 App (Var unpackCStringId) (mkLit (MachStr s))
 636
 637     is_NUL c = c == '\0'
 638 \end{code}
 639
 640 If an Integer is small enough (Haskell implementations must support
 641 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 642 otherwise, wrap with @addr2Integer@.
 643
 644 \begin{code}
 645 litToRep (NoRepInteger i integer_ty)
 646   = returnPM (integer_ty, rhs)
 647   where
 648     rhs | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 649           i < tARGET_MAX_INT
 650         = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
 651
 652         | otherwise                     -- Big, so start from a string
 653         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
 654
 655
 656 litToRep (NoRepRational r rational_ty)
 657   = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))     `thenPM` \ num_arg ->
 658     postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))     `thenPM` \ denom_arg ->
 659     returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
 660   where
 661     (ratio_data_con, integer_ty)
 662       = case (splitAlgTyConApp_maybe rational_ty) of
 663           Just (tycon, [i_ty], [con])
 664             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
 665                (con, i_ty)
 666
 667           _ -> (panic "ratio_data_con", panic "integer_ty")
 668
 669 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
 670 \end{code}
 671
 672
 673 %************************************************************************
 674 %*                                                                      *
 675 \subsection{The monad}
 676 %*                                                                      *
 677 %************************************************************************
 678
 679 \begin{code}
 680 type PostM a =  Bool                            -- True <=> inside a *value* lambda
 681              -> (UniqSupply, Bag CoreBind)      -- Unique supply and Floats in
 682              -> (a, (UniqSupply, Bag CoreBind))
 683
 684 initPM :: UniqSupply -> PostM a -> a
 685 initPM us m
 686   = case m False {- not inside lambda -} (us, emptyBag) of
 687         (result, _) -> result
 688
 689 returnPM v in_lam usf = (v, usf)
 690 thenPM m k in_lam usf = case m in_lam usf of
 691                                   (r, usf') -> k r in_lam usf'
 692
 693 mapPM f []     = returnPM []
 694 mapPM f (x:xs) = f x            `thenPM` \ r ->
 695                  mapPM f xs     `thenPM` \ rs ->
 696                  returnPM (r:rs)
 697
 698 insideLambda :: CoreBndr -> PostM a -> PostM a
 699 insideLambda bndr m in_lam usf | isId bndr = m True   usf
 700                                | otherwise = m in_lam usf
 701
 702 getInsideLambda :: PostM Bool
 703 getInsideLambda in_lam usf = (in_lam, usf)
 704
 705 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
 706 getFloatsPM m in_lam (us, floats)
 707   = let
 708         (a, (us', floats')) = m in_lam (us, emptyBag)
 709     in
 710     ((a, floats'), (us', floats))
 711
 712 addTopFloat :: Type -> CoreExpr -> PostM Id
 713 addTopFloat lit_ty lit_rhs in_lam (us, floats)
 714   = let
 715         (us1, us2) = splitUniqSupply us
 716         uniq       = uniqFromSupply us1
 717         lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
 718     in
 719     (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
 720 \end{code}
 721
 722