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