ghc/compiler/simplCore/SimplCore.lhs

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