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