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