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