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