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