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,
  13                           opt_D_dump_occur_anal,
  14                           opt_D_dump_simpl_iterations,
  15                           opt_D_simplifier_stats,
  16                           opt_D_dump_simpl,
  17                           opt_D_verbose_core2core,
  18                           opt_D_dump_occur_anal
  19                         )
  20 import CoreLint         ( beginPass, endPass )
  21 import CoreSyn
  22 import PprCore          ( pprCoreBindings )
  23 import OccurAnal        ( occurAnalyseBinds )
  24 import CoreUtils        ( exprIsTrivial, coreExprType )
  25 import Simplify         ( simplBind )
  26 import SimplUtils       ( etaCoreExpr, findDefault )
  27 import SimplMonad
  28 import CoreUnfold
  29 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
  30 import ErrUtils         ( dumpIfSet )
  31 import FloatIn          ( floatInwards )
  32 import FloatOut         ( floatOutwards )
  33 import Id               ( Id, mkSysLocal, mkUserId, isBottomingId,
  34                           idType, setIdType, idName, idInfo, idDetails
  35                         )
  36 import IdInfo           ( InlinePragInfo(..), specInfo, setSpecInfo,
  37                           inlinePragInfo, setInlinePragInfo,
  38                           setUnfoldingInfo
  39                         )
  40 import VarEnv
  41 import VarSet
  42 import Name             ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
  43                           Module, 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 Class            ( Class, classSelIds )
  54 import TysWiredIn       ( smallIntegerDataCon, isIntegerTy )
  55 import LiberateCase     ( liberateCase )
  56 import SAT              ( doStaticArgs )
  57 import Specialise       ( specProgram)
  58 import SpecEnv          ( specEnvToList, specEnvFromList )
  59 import StrictAnal       ( saWwTopBinds )
  60 import Var              ( TyVar, mkId )
  61 import Unique           ( Unique, Uniquable(..),
  62                           ratioTyConKey, mkUnique, incrUnique, initTidyUniques
  63                         )
  64 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply )
  65 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  66 import Util             ( mapAccumL )
  67 import SrcLoc           ( noSrcLoc )
  68 import Bag
  69 import Maybes
  70 import IO               ( hPutStr, stderr )
  71 import Outputable
  72
  73 import Ratio            ( numerator, denominator )
  74 \end{code}
  75
  76 \begin{code}
  77 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
  78           -> Module             -- Module name (profiling only)
  79           -> [Class]            -- Local classes
  80           -> UniqSupply         -- A name supply
  81           -> [CoreBind]         -- Input
  82           -> IO [CoreBind]      -- Result
  83
  84 core2core core_todos module_name classes us binds
  85   = do
  86         let (us1, us2) = splitUniqSupply us
  87
  88         -- Do the main business
  89         processed_binds <- doCorePasses us1 binds core_todos
  90
  91         -- Do the post-simplification business
  92         post_simpl_binds <- doPostSimplification us2 processed_binds
  93
  94         -- Do the final tidy-up
  95         final_binds <- tidyCorePgm module_name classes post_simpl_binds
  96
  97         -- Return results
  98         return final_binds
  99
 100 doCorePasses us binds []
 101   = return binds
 102
 103 doCorePasses us binds (to_do : to_dos)
 104   = do
 105         let (us1, us2) =  splitUniqSupply us
 106         binds1         <- doCorePass us1 binds to_do
 107         doCorePasses us2 binds1 to_dos
 108
 109 doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify"       simplifyPgm sw_chkr us binds
 110 doCorePass us binds CoreLiberateCase         = _scc_ "LiberateCase"   liberateCase binds
 111 doCorePass us binds CoreDoFloatInwards       = _scc_ "FloatInwards"   floatInwards binds
 112 doCorePass us binds CoreDoFullLaziness       = _scc_ "CoreFloating"   floatOutwards us binds
 113 doCorePass us binds CoreDoStaticArgs         = _scc_ "CoreStaticArgs" doStaticArgs us binds
 114 doCorePass us binds CoreDoStrictness         = _scc_ "CoreStranal"    saWwTopBinds us binds
 115 doCorePass us binds CoreDoSpecialising       = _scc_ "Specialise"     specProgram us binds
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{The driver for the simplifier}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 simplifyPgm :: (SimplifierSwitch -> SwitchResult)
 127             -> UniqSupply
 128             -> [CoreBind]               -- Input
 129             -> IO [CoreBind]            -- New bindings
 130
 131 simplifyPgm sw_chkr us binds
 132   = do {
 133         beginPass "Simplify";
 134
 135         (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
 136
 137         dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
 138                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 139                          text "",
 140                          pprSimplCount counts]);
 141
 142         endPass "Simplify"
 143                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
 144                 binds'
 145     }
 146   where
 147     max_iterations      = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 148     simpl_switch_is_on  = switchIsOn sw_chkr
 149
 150     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
 151                          | otherwise               = empty
 152
 153     iteration us iteration_no counts binds
 154       = do {
 155                 -- Occurrence analysis
 156            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
 157            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
 158                      (pprCoreBindings tagged_binds);
 159
 160                 -- Simplify
 161            let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
 162                  all_counts        = counts `plusSimplCount` counts'
 163                } ;
 164
 165                 -- Stop if nothing happened; don't dump output
 166            if isZeroSimplCount counts' then
 167                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 168            else do {
 169
 170                 -- Dump the result of this iteration
 171            dumpIfSet opt_D_dump_simpl_iterations
 172                      ("Simplifier iteration " ++ show iteration_no
 173                       ++ " out of " ++ show max_iterations)
 174                      (vcat[pprSimplCount counts',
 175                            text "",
 176                            core_iter_dump binds']) ;
 177
 178                 -- Stop if we've run out of iterations
 179            if iteration_no == max_iterations then
 180                 do {
 181                     if  max_iterations > 1 then
 182                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 183                                     show max_iterations ++
 184                                     " iterations; bailing out.\n")
 185                     else return ();
 186
 187                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 188                 }
 189
 190                 -- Else loop
 191            else iteration us2 (iteration_no + 1) all_counts binds'
 192         }  }
 193       where
 194           (us1, us2) = splitUniqSupply us
 195
 196
 197 simplTopBinds binds = go binds          `thenSmpl` \ (binds', _) ->
 198                       returnSmpl binds'
 199                     where
 200                       go []              = returnSmpl ([], ())
 201                       go (bind1 : binds) = simplBind bind1 (go binds)
 202 \end{code}
 203
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsection{Tidying core}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 Several tasks are done by @tidyCorePgm@
 212
 213 1.  Make certain top-level bindings into Globals. The point is that
 214     Global things get externally-visible labels at code generation
 215     time
 216
 217
 218 2. Give all binders a nice print-name.  Their uniques aren't changed;
 219    rather we give them lexically unique occ-names, so that we can
 220    safely print the OccNae only in the interface file.  [Bad idea to
 221    change the uniques, because the code generator makes global labels
 222    from the uniques for local thunks etc.]
 223
 224
 225 \begin{code}
 226 tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
 227 tidyCorePgm mod local_classes binds_in
 228   = do
 229         beginPass "Tidy Core"
 230         let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
 231         endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
 232   where
 233         -- Make sure to avoid the names of class operations
 234         -- They don't have top-level bindings, so we won't see them
 235         -- in binds_in; so we must initialise the tidy_env appropriately
 236         --
 237         -- We also make sure to avoid any exported binders.  Consider
 238         --      f{-u1-} = 1     -- Local decl
 239         --      ...
 240         --      f{-u2-} = 2     -- Exported decl
 241         --
 242         -- The second exported decl must 'get' the name 'f', so we
 243         -- have to put 'f' in the avoids list before we get to the first
 244         -- decl.  Name.tidyName then does a no-op on exported binders.
 245     init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
 246     avoids        = [getOccName sel_id | cls <- local_classes,
 247                                          sel_id <- classSelIds cls]
 248                     ++
 249                     [getOccName bndr | bind <- binds_in,
 250                                        bndr <- bindersOf bind,
 251                                        isExported bndr]
 252
 253 tidyBind :: Maybe Module                -- (Just m) for top level, Nothing for nested
 254          -> TidyEnv
 255          -> CoreBind
 256          -> (TidyEnv, CoreBind)
 257 tidyBind maybe_mod env (NonRec bndr rhs)
 258   = let
 259         (env', bndr') = tidyBndr maybe_mod env bndr
 260         rhs'          = tidyExpr env rhs
 261     in
 262     (env', NonRec bndr' rhs')
 263
 264 tidyBind maybe_mod env (Rec pairs)
 265   = let
 266         -- We use env' when tidying the rhss
 267         -- When tidying the binder itself we may tidy it's
 268         -- specialisations; if any of these mention other binders
 269         -- in the group we should really feed env' to them too;
 270         -- but that seems (a) unlikely and (b) a bit tiresome.
 271         -- So I left it out for now
 272
 273         (bndrs, rhss)  = unzip pairs
 274         (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
 275         rhss'          = map (tidyExpr env') rhss
 276   in
 277   (env', Rec (zip bndrs' rhss'))
 278
 279 tidyExpr env (Type ty)       = Type (tidyType env ty)
 280 tidyExpr env (Con con args)  = Con con (map (tidyExpr env) args)
 281 tidyExpr env (App f a)       = App (tidyExpr env f) (tidyExpr env a)
 282 tidyExpr env (Note n e)      = Note (tidyNote env n) (tidyExpr env e)
 283
 284 tidyExpr env (Let b e)       = Let b' (tidyExpr env' e)
 285                              where
 286                                (env', b') = tidyBind Nothing env b
 287
 288 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
 289                              where
 290                                (env', b') = tidyNestedBndr env b
 291
 292 tidyExpr env (Var v)         = case lookupVarEnv var_env v of
 293                                   Just v' -> Var v'
 294                                   Nothing -> Var v
 295                              where
 296                                (_, var_env) = env
 297
 298 tidyExpr env (Lam b e)       = Lam b' (tidyExpr env' e)
 299                              where
 300                                (env', b') = tidyNestedBndr env b
 301
 302 tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
 303                              where
 304                                (env', vs') = mapAccumL tidyNestedBndr env vs
 305
 306 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 307
 308 tidyNote env note            = note
 309 \end{code}
 310
 311 \begin{code}
 312 tidyBndr (Just mod) env id  = tidyTopBndr mod env id
 313 tidyBndr Nothing    env var = tidyNestedBndr  env var
 314
 315 tidyNestedBndr env tyvar
 316   | isTyVar tyvar
 317   = tidyTyVar env tyvar
 318
 319 tidyNestedBndr env@(tidy_env, var_env) id
 320   =     -- Non-top-level variables
 321     let
 322         -- Give the Id a fresh print-name, *and* rename its type
 323         -- The SrcLoc isn't important now, though we could extract it from the Id
 324         name'             = mkLocalName (getUnique id) occ' noSrcLoc
 325         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 326         ty'               = tidyType env (idType id)
 327         id'               = mkUserId name' ty'
 328                         -- NB: This throws away the IdInfo of the Id, which we
 329                         -- no longer need.  That means we don't need to
 330                         -- run over it with env, nor renumber it.
 331         var_env'          = extendVarEnv var_env id id'
 332     in
 333     ((tidy_env', var_env'), id')
 334
 335 tidyTopBndr mod env@(tidy_env, var_env) id
 336   =     -- Top level variables
 337     let
 338         (tidy_env', name') = tidyTopName mod tidy_env (idName id)
 339         ty'                = tidyTopType (idType id)
 340         idinfo'            = tidyIdInfo env (idInfo id)
 341         id'                = mkId name' ty' (idDetails id) idinfo'
 342         var_env'           = extendVarEnv var_env id id'
 343     in
 344     ((tidy_env', var_env'), id')
 345
 346 -- tidyIdInfo does these things:
 347 --      a) tidy the specialisation info (if any)
 348 --      b) zap a complicated ICanSafelyBeINLINEd pragma,
 349 --      c) zap the unfolding
 350 -- The latter two are to avoid space leaks
 351
 352 tidyIdInfo env info
 353   = info3
 354   where
 355     spec_items = specEnvToList (specInfo info)
 356     spec_env'  = specEnvFromList (map tidy_item spec_items)
 357     info1 | null spec_items = info
 358           | otherwise       = spec_env' `setSpecInfo` info
 359
 360     info2 = case inlinePragInfo info of
 361                 ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
 362                 other                   -> info1
 363
 364     info3 = noUnfolding `setUnfoldingInfo` info2
 365
 366     tidy_item (tyvars, tys, rhs)
 367         = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)
 368         where
 369           (env', tyvars') = tidyTyVars env tyvars
 370 \end{code}
 371
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection{PostSimplification}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 Several tasks are performed by the post-simplification pass
 381
 382 1.  Make the representation of NoRep literals explicit, and
 383     float their bindings to the top level.  We only do the floating
 384     part for NoRep lits inside a lambda (else no gain).  We need to
 385     take care with      let x = "foo" in e
 386     that we don't end up with a silly binding
 387                         let x = y in e
 388     with a floated "foo".  What a bore.
 389
 390 2.  *Mangle* cases involving par# in the discriminant.  The unfolding
 391     for par in PrelConc.lhs include case expressions with integer
 392     results solely to fool the strictness analyzer, the simplifier,
 393     and anyone else who might want to fool with the evaluation order.
 394     At this point in the compiler our evaluation order is safe.
 395     Therefore, we convert expressions of the form:
 396
 397         case par# e of
 398           0# -> rhs
 399           _  -> parError#
 400     ==>
 401         case par# e of
 402           _ -> rhs
 403
 404     fork# isn't handled like this - it's an explicit IO operation now.
 405     The reason is that fork# returns a ThreadId#, which gets in the
 406     way of the above scheme.  And anyway, IO is the only guaranteed
 407     way to enforce ordering  --SDM.
 408
 409 3.  Mangle cases involving seq# in the discriminant.  Up to this
 410     point, seq# will appear like this:
 411
 412           case seq# e of
 413                 0# -> seqError#
 414                 _  -> ...
 415
 416     where the 0# branch is purely to bamboozle the strictness analyser
 417     (see case 4 above).  This code comes from an unfolding for 'seq'
 418     in Prelude.hs.  We translate this into
 419
 420           case e of
 421                 _ -> ...
 422
 423     Now that the evaluation order is safe.
 424
 425 4. Do eta reduction for lambda abstractions appearing in:
 426         - the RHS of case alternatives
 427         - the body of a let
 428
 429    These will otherwise turn into local bindings during Core->STG;
 430    better to nuke them if possible.  (In general the simplifier does
 431    eta expansion not eta reduction, up to this point.  It does eta
 432    on the RHSs of bindings but not the RHSs of case alternatives and
 433    let bodies)
 434
 435
 436 ------------------- NOT DONE ANY MORE ------------------------
 437 [March 98] Indirections are now elimianted by the occurrence analyser
 438 1.  Eliminate indirections.  The point here is to transform
 439         x_local = E
 440         x_exported = x_local
 441     ==>
 442         x_exported = E
 443
 444 [Dec 98] [Not now done because there is no penalty in the code
 445           generator for using the former form]
 446 2.  Convert
 447         case x of {...; x' -> ...x'...}
 448     ==>
 449         case x of {...; _  -> ...x... }
 450     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 451 --------------------------------------------------------------
 452
 453 Special case
 454 ~~~~~~~~~~~~
 455
 456 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
 457 things, and we need local Ids for non-floated stuff):
 458
 459   Don't float stuff out of a binder that's marked as a bottoming Id.
 460   Reason: it doesn't do any good, and creates more CAFs that increase
 461   the size of SRTs.
 462
 463 eg.
 464
 465         f = error "string"
 466
 467 is translated to
 468
 469         f' = unpackCString# "string"
 470         f = error f'
 471
 472 hence f' and f become CAFs.  Instead, the special case for
 473 tidyTopBinding below makes sure this comes out as
 474
 475         f = let f' = unpackCString# "string" in error f'
 476
 477 and we can safely ignore f as a CAF, since it can only ever be entered once.
 478
 479
 480
 481 \begin{code}
 482 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
 483 doPostSimplification us binds_in
 484   = do
 485         beginPass "Post-simplification pass"
 486         let binds_out = initPM us (postSimplTopBinds binds_in)
 487         endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
 488
 489 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
 490 postSimplTopBinds binds
 491   = mapPM postSimplTopBind binds        `thenPM` \ binds' ->
 492     returnPM (bagToList (unionManyBags binds'))
 493
 494 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
 495 postSimplTopBind (NonRec bndr rhs)
 496   | isBottomingId bndr          -- Don't lift out floats for bottoming Ids
 497                                 -- See notes above
 498   = getFloatsPM (postSimplExpr rhs)     `thenPM` \ (rhs', floats) ->
 499     returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
 500
 501 postSimplTopBind bind
 502   = getFloatsPM (postSimplBind bind)    `thenPM` \ (bind', floats) ->
 503     returnPM (floats `snocBag` bind')
 504
 505 postSimplBind (NonRec bndr rhs)
 506   = postSimplExpr rhs           `thenPM` \ rhs' ->
 507     returnPM (NonRec bndr rhs')
 508
 509 postSimplBind (Rec pairs)
 510   = mapPM postSimplExpr rhss    `thenPM` \ rhss' ->
 511     returnPM (Rec (bndrs `zip` rhss'))
 512   where
 513     (bndrs, rhss) = unzip pairs
 514 \end{code}
 515
 516
 517 Expressions
 518 ~~~~~~~~~~~
 519 \begin{code}
 520 postSimplExpr (Var v)   = returnPM (Var v)
 521 postSimplExpr (Type ty) = returnPM (Type ty)
 522
 523 postSimplExpr (App fun arg)
 524   = postSimplExpr fun   `thenPM` \ fun' ->
 525     postSimplExpr arg   `thenPM` \ arg' ->
 526     returnPM (App fun' arg')
 527
 528 postSimplExpr (Con (Literal lit) args)
 529   = ASSERT( null args )
 530     litToRep lit        `thenPM` \ (lit_ty, lit_expr) ->
 531     getInsideLambda     `thenPM` \ in_lam ->
 532     if in_lam && not (exprIsTrivial lit_expr) then
 533         -- It must have been a no-rep literal with a
 534         -- non-trivial representation; and we're inside a lambda;
 535         -- so float it to the top
 536         addTopFloat lit_ty lit_expr     `thenPM` \ v ->
 537         returnPM (Var v)
 538     else
 539         returnPM lit_expr
 540
 541 postSimplExpr (Con con args)
 542   = mapPM postSimplExpr args    `thenPM` \ args' ->
 543     returnPM (Con con args')
 544
 545 postSimplExpr (Lam bndr body)
 546   = insideLambda bndr           $
 547     postSimplExpr body          `thenPM` \ body' ->
 548     returnPM (Lam bndr body')
 549
 550 postSimplExpr (Let bind body)
 551   = postSimplBind bind          `thenPM` \ bind' ->
 552     postSimplExprEta body       `thenPM` \ body' ->
 553     returnPM (Let bind' body')
 554
 555 postSimplExpr (Note note body)
 556   = postSimplExprEta body       `thenPM` \ body' ->
 557     returnPM (Note note body')
 558
 559 -- seq#: see notes above.
 560 -- NB: seq# :: forall a. a -> Int#
 561 postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
 562   = postSimplExpr e                     `thenPM` \ e' ->
 563     let
 564         -- The old binder can't have been used, so we
 565         -- can gaily re-use it (yuk!)
 566         new_bndr = setIdType bndr ty
 567     in
 568     postSimplExprEta default_rhs        `thenPM` \ rhs' ->
 569     returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
 570   where
 571     (other_alts, maybe_default)  = findDefault alts
 572     Just default_rhs             = maybe_default
 573
 574 -- par#: see notes above.
 575 postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
 576   | funnyParallelOp op && maybeToBool maybe_default
 577   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 578     postSimplExprEta default_rhs        `thenPM` \ rhs' ->
 579     returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
 580   where
 581     (other_alts, maybe_default)  = findDefault alts
 582     Just default_rhs             = maybe_default
 583
 584 postSimplExpr (Case scrut case_bndr alts)
 585   = postSimplExpr scrut                 `thenPM` \ scrut' ->
 586     mapPM ps_alt alts                   `thenPM` \ alts' ->
 587     returnPM (Case scrut' case_bndr alts')
 588   where
 589     ps_alt (con,bndrs,rhs) = postSimplExprEta rhs       `thenPM` \ rhs' ->
 590                              returnPM (con, bndrs, rhs')
 591
 592 postSimplExprEta e = postSimplExpr e    `thenPM` \ e' ->
 593                      returnPM (etaCoreExpr e')
 594 \end{code}
 595
 596 \begin{code}
 597 funnyParallelOp ParOp  = True
 598 funnyParallelOp _      = False
 599 \end{code}
 600
 601
 602 %************************************************************************
 603 %*                                                                      *
 604 \subsection[coreToStg-lits]{Converting literals}
 605 %*                                                                      *
 606 %************************************************************************
 607
 608 Literals: the NoRep kind need to be de-no-rep'd.
 609 We always replace them with a simple variable, and float a suitable
 610 binding out to the top level.
 611
 612 \begin{code}
 613 litToRep :: Literal -> PostM (Type, CoreExpr)
 614
 615 litToRep (NoRepStr s ty)
 616   = returnPM (ty, rhs)
 617   where
 618     rhs = if (any is_NUL (_UNPK_ s))
 619
 620           then   -- Must cater for NULs in literal string
 621                 mkApps (Var unpackCString2Id)
 622                        [mkLit (MachStr s),
 623                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
 624
 625           else  -- No NULs in the string
 626                 App (Var unpackCStringId) (mkLit (MachStr s))
 627
 628     is_NUL c = c == '\0'
 629 \end{code}
 630
 631 If an Integer is small enough (Haskell implementations must support
 632 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 633 otherwise, wrap with @addr2Integer@.
 634
 635 \begin{code}
 636 litToRep (NoRepInteger i integer_ty)
 637   = returnPM (integer_ty, rhs)
 638   where
 639     rhs | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 640           i < tARGET_MAX_INT
 641         = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
 642
 643         | otherwise                     -- Big, so start from a string
 644         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
 645
 646
 647 litToRep (NoRepRational r rational_ty)
 648   = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))     `thenPM` \ num_arg ->
 649     postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))     `thenPM` \ denom_arg ->
 650     returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
 651   where
 652     (ratio_data_con, integer_ty)
 653       = case (splitAlgTyConApp_maybe rational_ty) of
 654           Just (tycon, [i_ty], [con])
 655             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
 656                (con, i_ty)
 657
 658           _ -> (panic "ratio_data_con", panic "integer_ty")
 659
 660 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
 661 \end{code}
 662
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection{The monad}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 \begin{code}
 671 type PostM a =  Bool                            -- True <=> inside a *value* lambda
 672              -> (UniqSupply, Bag CoreBind)      -- Unique supply and Floats in
 673              -> (a, (UniqSupply, Bag CoreBind))
 674
 675 initPM :: UniqSupply -> PostM a -> a
 676 initPM us m
 677   = case m False {- not inside lambda -} (us, emptyBag) of
 678         (result, _) -> result
 679
 680 returnPM v in_lam usf = (v, usf)
 681 thenPM m k in_lam usf = case m in_lam usf of
 682                                   (r, usf') -> k r in_lam usf'
 683
 684 mapPM f []     = returnPM []
 685 mapPM f (x:xs) = f x            `thenPM` \ r ->
 686                  mapPM f xs     `thenPM` \ rs ->
 687                  returnPM (r:rs)
 688
 689 insideLambda :: CoreBndr -> PostM a -> PostM a
 690 insideLambda bndr m in_lam usf | isId bndr = m True   usf
 691                                | otherwise = m in_lam usf
 692
 693 getInsideLambda :: PostM Bool
 694 getInsideLambda in_lam usf = (in_lam, usf)
 695
 696 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
 697 getFloatsPM m in_lam (us, floats)
 698   = let
 699         (a, (us', floats')) = m in_lam (us, emptyBag)
 700     in
 701     ((a, floats'), (us', floats))
 702
 703 addTopFloat :: Type -> CoreExpr -> PostM Id
 704 addTopFloat lit_ty lit_rhs in_lam (us, floats)
 705   = let
 706         (us1, us2) = splitUniqSupply us
 707         uniq       = uniqFromSupply us1
 708         lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
 709     in
 710     (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
 711 \end{code}
 712
 713