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