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