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, intSwitchSet,
  13                           opt_D_dump_occur_anal, opt_D_dump_rules,
  14                           opt_D_dump_simpl_iterations,
  15                           opt_D_dump_simpl_stats,
  16                           opt_D_dump_simpl, opt_D_dump_rules,
  17                           opt_D_verbose_core2core,
  18                           opt_D_dump_occur_anal,
  19                           opt_UsageSPOn,
  20                         )
  21 import CoreLint         ( beginPass, endPass )
  22 import CoreSyn
  23 import CSE              ( cseProgram )
  24 import Rules            ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
  25 import CoreUnfold
  26 import PprCore          ( pprCoreBindings )
  27 import OccurAnal        ( occurAnalyseBinds )
  28 import CoreUtils        ( exprIsTrivial, coreExprType )
  29 import Simplify         ( simplTopBinds, simplExpr )
  30 import SimplUtils       ( etaCoreExpr, findDefault, simplBinders )
  31 import SimplMonad
  32 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
  33 import ErrUtils         ( dumpIfSet )
  34 import FloatIn          ( floatInwards )
  35 import FloatOut         ( floatOutwards )
  36 import Id               ( Id, mkSysLocal, mkVanillaId, isBottomingId,
  37                           idType, setIdType, idName, idInfo, setIdNoDiscard
  38                         )
  39 import VarEnv
  40 import VarSet
  41 import Module           ( Module )
  42 import Name             ( mkLocalName, tidyOccName, tidyTopName,
  43                           NamedThing(..), OccName
  44                         )
  45 import TyCon            ( TyCon, isDataTyCon )
  46 import PrelInfo         ( unpackCStringId, unpackCString2Id, addr2IntegerId )
  47 import PrelRules        ( builtinRules )
  48 import Type             ( Type, splitAlgTyConApp_maybe,
  49                           isUnLiftedType,
  50                           tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
  51                           Type
  52                         )
  53 import TysWiredIn       ( smallIntegerDataCon, isIntegerTy )
  54 import LiberateCase     ( liberateCase )
  55 import SAT              ( doStaticArgs )
  56 import Specialise       ( specProgram)
  57 import UsageSPInf       ( doUsageSPInf )
  58 import StrictAnal       ( saBinds )
  59 import WorkWrap         ( wwTopBinds )
  60 import CprAnalyse       ( cprAnalyse )
  61
  62 import Unique           ( Unique, Uniquable(..),
  63                           ratioTyConKey
  64                         )
  65 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, 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 %************************************************************************
  78 %*                                                                      *
  79 \subsection{The driver for the simplifier}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
  85           -> [CoreBind]         -- Binds in
  86           -> [ProtoCoreRule]    -- Rules
  87           -> IO ([CoreBind], [ProtoCoreRule])
  88
  89 core2core core_todos binds rules
  90   = do
  91         us <-  mkSplitUniqSupply 's'
  92         let (cp_us, us1)   = splitUniqSupply us
  93             (ru_us, ps_us) = splitUniqSupply us1
  94
  95         better_rules <- simplRules ru_us rules binds
  96
  97         let all_rules = builtinRules ++ better_rules
  98         -- Here is where we add in the built-in rules
  99
 100         let (binds1, rule_base) = prepareRuleBase binds all_rules
 101
 102         -- Do the main business
 103         (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
 104                                                  rule_base core_todos
 105
 106         dumpIfSet opt_D_dump_simpl_stats
 107                   "Grand total simplifier statistics"
 108                   (pprSimplCount stats)
 109
 110         -- Do the post-simplification business
 111         post_simpl_binds <- doPostSimplification ps_us processed_binds
 112
 113         -- Return results
 114         return (post_simpl_binds, filter orphanRule better_rules)
 115
 116
 117 doCorePasses stats us binds irs []
 118   = return (stats, binds)
 119
 120 doCorePasses stats us binds irs (to_do : to_dos)
 121   = do
 122         let (us1, us2) =  splitUniqSupply us
 123         (stats1, binds1) <- doCorePass us1 binds irs to_do
 124         doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
 125
 126 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
 127 doCorePass us binds rb CoreCSE                  = _scc_ "CommonSubExpr" noStats (cseProgram binds)
 128 doCorePass us binds rb CoreLiberateCase         = _scc_ "LiberateCase"  noStats (liberateCase binds)
 129 doCorePass us binds rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
 130 doCorePass us binds rb CoreDoFullLaziness       = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
 131 doCorePass us binds rb CoreDoStaticArgs         = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
 132 doCorePass us binds rb CoreDoStrictness         = _scc_ "Stranal"       noStats (saBinds binds)
 133 doCorePass us binds rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
 134 doCorePass us binds rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
 135 doCorePass us binds rb CoreDoCPResult           = _scc_ "CPResult"      noStats (cprAnalyse binds)
 136 doCorePass us binds rb CoreDoPrintCore          = _scc_ "PrintCore"     noStats (printCore binds)
 137 doCorePass us binds rb CoreDoUSPInf
 138   = _scc_ "CoreUsageSPInf"
 139     if opt_UsageSPOn then
 140       noStats (doUsageSPInf us binds)
 141     else
 142       trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
 143       noStats (return binds)
 144
 145 printCore binds = do dumpIfSet True "Print Core"
 146                                (pprCoreBindings binds)
 147                      return binds
 148
 149 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
 150 \end{code}
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection{Dealing with rules}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 We must do some gentle simplifiation on the template (but not the RHS)
 160 of each rule.  The case that forced me to add this was the fold/build rule,
 161 which without simplification looked like:
 162         fold k z (build (/\a. g a))  ==>  ...
 163 This doesn't match unless you do eta reduction on the build argument.
 164
 165 \begin{code}
 166 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
 167 simplRules us rules binds
 168   = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
 169
 170         dumpIfSet opt_D_dump_rules
 171                   "Transformation rules"
 172                   (vcat (map pprProtoCoreRule better_rules))
 173
 174         return better_rules
 175   where
 176     black_list_all v = True             -- This stops all inlining
 177     sw_chkr any = SwBool False          -- A bit bogus
 178
 179         -- Boringly, we need to gather the in-scope set.
 180         -- Typically this thunk won't even be force, but the test in
 181         -- simpVar fails if it isn't right, and it might conceivably matter
 182     bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 183
 184
 185 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
 186   | not is_local
 187   = returnSmpl rule     -- No need to fiddle with imported rules
 188   | otherwise
 189   = simplBinders bndrs                  $ \ bndrs' ->
 190     mapSmpl simpl_arg args              `thenSmpl` \ args' ->
 191     simplExpr rhs                       `thenSmpl` \ rhs' ->
 192     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
 193
 194 simpl_arg e
 195 --  I've seen rules in which a LHS like
 196 --      augment g (build h)
 197 -- turns into
 198 --      augment (\a. g a) (build h)
 199 -- So it's a help to eta-reduce the args as we simplify them.
 200 -- Otherwise we don't match when given an argument like
 201 --      (\a. h a a)
 202   = simplExpr e         `thenSmpl` \ e' ->
 203     returnSmpl (etaCoreExpr e')
 204 \end{code}
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{The driver for the simplifier}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 simplifyPgm :: RuleBase
 214             -> (SimplifierSwitch -> SwitchResult)
 215             -> UniqSupply
 216             -> [CoreBind]                               -- Input
 217             -> IO (SimplCount, [CoreBind])              -- New bindings
 218
 219 simplifyPgm (imported_rule_ids, rule_lhs_fvs)
 220             sw_chkr us binds
 221   = do {
 222         beginPass "Simplify";
 223
 224         -- Glom all binds together in one Rec, in case any
 225         -- transformations have introduced any new dependencies
 226         --
 227         -- NB: the global invariant is this:
 228         --      *** the top level bindings are never cloned, and are always unique ***
 229         --
 230         -- We sort them into dependency order, but applying transformation rules may
 231         -- make something at the top refer to something at the bottom:
 232         --      f = \x -> p (q x)
 233         --      h = \y -> 3
 234         --
 235         --      RULE:  p (q x) = h x
 236         --
 237         -- Applying this rule makes f refer to h, although it doesn't appear to in the
 238         -- source program.  Our solution is to do this occasional glom-together step,
 239         -- just once per overall simplfication step.
 240
 241         let { recd_binds = [Rec (flattenBinds binds)] };
 242
 243         (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
 244
 245         dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
 246                   "Simplifier statistics"
 247                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 248                          text "",
 249                          pprSimplCount counts_out]);
 250
 251         endPass "Simplify"
 252                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
 253                 binds' ;
 254
 255         return (counts_out, binds')
 256     }
 257   where
 258     max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 259     black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
 260
 261     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
 262                          | otherwise               = empty
 263
 264     iteration us iteration_no counts binds
 265       = do {
 266                 -- Occurrence analysis
 267            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
 268
 269            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
 270                      (pprCoreBindings tagged_binds);
 271
 272                 -- Simplify
 273            let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
 274                                               black_list_fn
 275                                               (simplTopBinds tagged_binds);
 276                         -- The imported_rule_ids are used by initSmpl to initialise
 277                         -- the in-scope set.  That way, the simplifier will change any
 278                         -- occurrences of the imported id to the one in the imported_rule_ids
 279                         -- set, which are decorated with their rules.
 280
 281                  all_counts        = counts `plusSimplCount` counts'
 282                } ;
 283
 284                 -- Stop if nothing happened; don't dump output
 285            if isZeroSimplCount counts' then
 286                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 287            else do {
 288
 289                 -- Dump the result of this iteration
 290            dumpIfSet opt_D_dump_simpl_iterations
 291                      ("Simplifier iteration " ++ show iteration_no
 292                       ++ " out of " ++ show max_iterations)
 293                      (pprSimplCount counts') ;
 294
 295            if opt_D_dump_simpl_iterations then
 296                 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
 297                         opt_D_verbose_core2core
 298                         binds'
 299            else
 300                 return [] ;
 301
 302                 -- Stop if we've run out of iterations
 303            if iteration_no == max_iterations then
 304                 do {
 305 #ifdef DEBUG
 306                     if  max_iterations > 2 then
 307                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 308                                     show max_iterations ++
 309                                     " iterations; bailing out.\n")
 310                     else
 311 #endif
 312                         return ();
 313
 314                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 315                 }
 316
 317                 -- Else loop
 318            else iteration us2 (iteration_no + 1) all_counts binds'
 319         }  }
 320       where
 321           (us1, us2) = splitUniqSupply us
 322 \end{code}
 323
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsection{PostSimplification}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331 Several tasks are performed by the post-simplification pass
 332
 333 1.  Make the representation of NoRep literals explicit, and
 334     float their bindings to the top level.  We only do the floating
 335     part for NoRep lits inside a lambda (else no gain).  We need to
 336     take care with      let x = "foo" in e
 337     that we don't end up with a silly binding
 338                         let x = y in e
 339     with a floated "foo".  What a bore.
 340
 341 4. Do eta reduction for lambda abstractions appearing in:
 342         - the RHS of case alternatives
 343         - the body of a let
 344
 345    These will otherwise turn into local bindings during Core->STG;
 346    better to nuke them if possible.  (In general the simplifier does
 347    eta expansion not eta reduction, up to this point.  It does eta
 348    on the RHSs of bindings but not the RHSs of case alternatives and
 349    let bodies)
 350
 351
 352 ------------------- NOT DONE ANY MORE ------------------------
 353 [March 98] Indirections are now elimianted by the occurrence analyser
 354 1.  Eliminate indirections.  The point here is to transform
 355         x_local = E
 356         x_exported = x_local
 357     ==>
 358         x_exported = E
 359
 360 [Dec 98] [Not now done because there is no penalty in the code
 361           generator for using the former form]
 362 2.  Convert
 363         case x of {...; x' -> ...x'...}
 364     ==>
 365         case x of {...; _  -> ...x... }
 366     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 367 --------------------------------------------------------------
 368
 369 Special case
 370 ~~~~~~~~~~~~
 371
 372 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
 373 things, and we need local Ids for non-floated stuff):
 374
 375   Don't float stuff out of a binder that's marked as a bottoming Id.
 376   Reason: it doesn't do any good, and creates more CAFs that increase
 377   the size of SRTs.
 378
 379 eg.
 380
 381         f = error "string"
 382
 383 is translated to
 384
 385         f' = unpackCString# "string"
 386         f = error f'
 387
 388 hence f' and f become CAFs.  Instead, the special case for
 389 tidyTopBinding below makes sure this comes out as
 390
 391         f = let f' = unpackCString# "string" in error f'
 392
 393 and we can safely ignore f as a CAF, since it can only ever be entered once.
 394
 395
 396
 397 \begin{code}
 398 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
 399 doPostSimplification us binds_in
 400   = do
 401         beginPass "Post-simplification pass"
 402         let binds_out = initPM us (postSimplTopBinds binds_in)
 403         endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
 404
 405 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
 406 postSimplTopBinds binds
 407   = mapPM postSimplTopBind binds        `thenPM` \ binds' ->
 408     returnPM (bagToList (unionManyBags binds'))
 409
 410 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
 411 postSimplTopBind (NonRec bndr rhs)
 412   | isBottomingId bndr          -- Don't lift out floats for bottoming Ids
 413                                 -- See notes above
 414   = getFloatsPM (postSimplExpr rhs)     `thenPM` \ (rhs', floats) ->
 415     returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
 416
 417 postSimplTopBind bind
 418   = getFloatsPM (postSimplBind bind)    `thenPM` \ (bind', floats) ->
 419     returnPM (floats `snocBag` bind')
 420
 421 postSimplBind (NonRec bndr rhs)
 422   = postSimplExpr rhs           `thenPM` \ rhs' ->
 423     returnPM (NonRec bndr rhs')
 424
 425 postSimplBind (Rec pairs)
 426   = mapPM postSimplExpr rhss    `thenPM` \ rhss' ->
 427     returnPM (Rec (bndrs `zip` rhss'))
 428   where
 429     (bndrs, rhss) = unzip pairs
 430 \end{code}
 431
 432
 433 Expressions
 434 ~~~~~~~~~~~
 435 \begin{code}
 436 postSimplExpr (Var v)   = returnPM (Var v)
 437 postSimplExpr (Type ty) = returnPM (Type ty)
 438
 439 postSimplExpr (App fun arg)
 440   = postSimplExpr fun   `thenPM` \ fun' ->
 441     postSimplExpr arg   `thenPM` \ arg' ->
 442     returnPM (App fun' arg')
 443
 444 postSimplExpr (Con (Literal lit) args)
 445   = ASSERT( null args )
 446     litToRep lit        `thenPM` \ (lit_ty, lit_expr) ->
 447     getInsideLambda     `thenPM` \ in_lam ->
 448     if in_lam && not (exprIsTrivial lit_expr) then
 449         -- It must have been a no-rep literal with a
 450         -- non-trivial representation; and we're inside a lambda;
 451         -- so float it to the top
 452         addTopFloat lit_ty lit_expr     `thenPM` \ v ->
 453         returnPM (Var v)
 454     else
 455         returnPM lit_expr
 456
 457 postSimplExpr (Con con args)
 458   = mapPM postSimplExpr args    `thenPM` \ args' ->
 459     returnPM (Con con args')
 460
 461 postSimplExpr (Lam bndr body)
 462   = insideLambda bndr           $
 463     postSimplExpr body          `thenPM` \ body' ->
 464     returnPM (Lam bndr body')
 465
 466 postSimplExpr (Let bind body)
 467   = postSimplBind bind          `thenPM` \ bind' ->
 468     postSimplExprEta body       `thenPM` \ body' ->
 469     returnPM (Let bind' body')
 470
 471 postSimplExpr (Note note body)
 472   = postSimplExpr body          `thenPM` \ body' ->
 473         -- Do *not* call postSimplExprEta here
 474         -- We don't want to turn f = \x -> coerce t (\y -> f x y)
 475         -- into                  f = \x -> coerce t (f x)
 476         -- because then f has a lower arity.
 477         -- This is not only bad in general, it causes the arity to
 478         -- not match the [Demand] on an Id,
 479         -- which confuses the importer of this module.
 480     returnPM (Note note body')
 481
 482 postSimplExpr (Case scrut case_bndr alts)
 483   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 484     mapPM ps_alt alts                   `thenPM` \ alts' ->
 485     returnPM (Case scrut' case_bndr alts')
 486   where
 487     ps_alt (con,bndrs,rhs) = postSimplExprEta rhs       `thenPM` \ rhs' ->
 488                              returnPM (con, bndrs, rhs')
 489
 490 postSimplExprEta e = postSimplExpr e    `thenPM` \ e' ->
 491                      returnPM (etaCoreExpr e')
 492 \end{code}
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection[coreToStg-lits]{Converting literals}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 Literals: the NoRep kind need to be de-no-rep'd.
 502 We always replace them with a simple variable, and float a suitable
 503 binding out to the top level.
 504
 505 \begin{code}
 506 litToRep :: Literal -> PostM (Type, CoreExpr)
 507
 508 litToRep (NoRepStr s ty)
 509   = returnPM (ty, rhs)
 510   where
 511     rhs = if (any is_NUL (_UNPK_ s))
 512
 513           then   -- Must cater for NULs in literal string
 514                 mkApps (Var unpackCString2Id)
 515                        [mkLit (MachStr s),
 516                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
 517
 518           else  -- No NULs in the string
 519                 App (Var unpackCStringId) (mkLit (MachStr s))
 520
 521     is_NUL c = c == '\0'
 522 \end{code}
 523
 524 If an Integer is small enough (Haskell implementations must support
 525 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 526 otherwise, wrap with @addr2Integer@.
 527
 528 \begin{code}
 529 litToRep (NoRepInteger i integer_ty)
 530   = returnPM (integer_ty, rhs)
 531   where
 532     rhs | i >= tARGET_MIN_INT &&        -- Small enough, so start from an Int
 533           i <= tARGET_MAX_INT
 534         = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
 535
 536         | otherwise                     -- Big, so start from a string
 537         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
 538
 539
 540 litToRep (NoRepRational r rational_ty)
 541   = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))     `thenPM` \ num_arg ->
 542     postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))     `thenPM` \ denom_arg ->
 543     returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
 544   where
 545     (ratio_data_con, integer_ty)
 546       = case (splitAlgTyConApp_maybe rational_ty) of
 547           Just (tycon, [i_ty], [con])
 548             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
 549                (con, i_ty)
 550
 551           _ -> (panic "ratio_data_con", panic "integer_ty")
 552
 553 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
 554 \end{code}
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection{The monad}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 \begin{code}
 564 type PostM a =  Bool                            -- True <=> inside a *value* lambda
 565              -> (UniqSupply, Bag CoreBind)      -- Unique supply and Floats in
 566              -> (a, (UniqSupply, Bag CoreBind))
 567
 568 initPM :: UniqSupply -> PostM a -> a
 569 initPM us m
 570   = case m False {- not inside lambda -} (us, emptyBag) of
 571         (result, _) -> result
 572
 573 returnPM v in_lam usf = (v, usf)
 574 thenPM m k in_lam usf = case m in_lam usf of
 575                                   (r, usf') -> k r in_lam usf'
 576
 577 mapPM f []     = returnPM []
 578 mapPM f (x:xs) = f x            `thenPM` \ r ->
 579                  mapPM f xs     `thenPM` \ rs ->
 580                  returnPM (r:rs)
 581
 582 insideLambda :: CoreBndr -> PostM a -> PostM a
 583 insideLambda bndr m in_lam usf | isId bndr = m True   usf
 584                                | otherwise = m in_lam usf
 585
 586 getInsideLambda :: PostM Bool
 587 getInsideLambda in_lam usf = (in_lam, usf)
 588
 589 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
 590 getFloatsPM m in_lam (us, floats)
 591   = let
 592         (a, (us', floats')) = m in_lam (us, emptyBag)
 593     in
 594     ((a, floats'), (us', floats))
 595
 596 addTopFloat :: Type -> CoreExpr -> PostM Id
 597 addTopFloat lit_ty lit_rhs in_lam (us, floats)
 598   = let
 599         (us1, us2) = splitUniqSupply us
 600         uniq       = uniqFromSupply us1
 601         lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
 602     in
 603     (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
 604 \end{code}
 605
 606