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