ghc/compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[CoreToStg]{Converting core syntax to STG syntax}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
  11
  12
  13 \begin{code}
  14 #include "HsVersions.h"
  15
  16 module CoreToStg ( topCoreBindsToStg ) where
  17
  18 IMP_Ubiq(){-uitous-}
  19
  20 import CoreSyn          -- input
  21 import StgSyn           -- output
  22
  23 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
  24 import CoreUtils        ( coreExprType )
  25 import CostCentre       ( noCostCentre )
  26 import Id               ( mkSysLocal, idType, isBottomingId,
  27                           nullIdEnv, addOneToIdEnv, lookupIdEnv,
  28                           IdEnv(..), GenId{-instance NamedThing-}
  29                         )
  30 import Literal          ( mkMachInt, Literal(..) )
  31 import Name             ( isExported )
  32 import PrelVals         ( unpackCStringId, unpackCString2Id,
  33                           integerZeroId, integerPlusOneId,
  34                           integerPlusTwoId, integerMinusOneId
  35                         )
  36 import PrimOp           ( PrimOp(..) )
  37 import SpecUtils        ( mkSpecialisedCon )
  38 import SrcLoc           ( mkUnknownSrcLoc )
  39 import TyCon            ( TyCon{-instance Uniquable-} )
  40 import Type             ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
  41 import TysWiredIn       ( stringTy )
  42 import Unique           ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
  43 import UniqSupply       -- all of it, really
  44 import Util             ( panic, assertPanic, pprTrace{-ToDo:rm-} )
  45 import Pretty--ToDo:rm
  46 import PprStyle--ToDo:rm
  47 import PprType  --ToDo:rm
  48 import Outputable--ToDo:rm
  49 import PprEnv--ToDo:rm
  50
  51 isLeakFreeType x y = False -- safe option; ToDo
  52 \end{code}
  53
  54
  55         ***************  OVERVIEW   *********************
  56
  57
  58 The business of this pass is to convert Core to Stg.  On the way:
  59
  60 * We discard type lambdas and applications. In so doing we discard
  61   "trivial" bindings such as
  62         x = y t1 t2
  63   where t1, t2 are types
  64
  65 * We make the representation of NoRep literals explicit, and
  66   float their bindings to the top level
  67
  68 * We do *not* pin on the correct free/live var info; that's done later.
  69   Instead we use bOGUS_LVS and _FVS as a placeholder.
  70
  71 * We convert    case x of {...; x' -> ...x'...}
  72         to
  73                 case x of {...; _  -> ...x... }
  74
  75   See notes in SimplCase.lhs, near simplDefault for the reasoning here.
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection[coreToStg-programs]{Converting a core program and core bindings}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 Because we're going to come across ``boring'' bindings like
  85 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
  86 environment, so we can just replace all occurrences of \tr{x}
  87 with \tr{y}.
  88
  89 \begin{code}
  90 type StgEnv = IdEnv StgArg
  91 \end{code}
  92
  93 No free/live variable information is pinned on in this pass; it's added
  94 later.  For this pass
  95 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
  96
  97 \begin{code}
  98 bOGUS_LVs :: StgLiveVars
  99 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
 100
 101 bOGUS_FVs :: [Id]
 102 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
 103 \end{code}
 104
 105 \begin{code}
 106 topCoreBindsToStg :: UniqSupply -- name supply
 107                   -> [CoreBinding]      -- input
 108                   -> [StgBinding]       -- output
 109
 110 topCoreBindsToStg us core_binds
 111   = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
 112       (_, stuff) -> stuff
 113   where
 114     binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
 115
 116     binds_to_stg env [] = returnUs []
 117     binds_to_stg env (b:bs)
 118       = do_top_bind  env     b  `thenUs` \ (new_b, new_env, float_binds) ->
 119         binds_to_stg new_env bs `thenUs` \ new_bs ->
 120         returnUs (bagToList float_binds ++      -- Literals
 121                   new_b ++
 122                   new_bs)
 123
 124     do_top_bind env bind@(Rec pairs)
 125       = coreBindToStg env bind
 126
 127     do_top_bind env bind@(NonRec var rhs)
 128       = coreBindToStg env bind          `thenUs` \ (stg_binds, new_env, float_binds) ->
 129 {- TESTING:
 130         let
 131             ppr_blah xs = ppInterleave ppComma (map pp_x xs)
 132             pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
 133         in
 134         pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
 135 -}
 136         case stg_binds of
 137            [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
 138                 -- Mega-special case; there's still a binding there
 139                 -- no fvs (of course), *no args*, "let" rhs
 140                 let
 141                   (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
 142                 in
 143                 returnUs (extra_float_binds ++
 144                           [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
 145                           new_env,
 146                           float_binds)
 147
 148            other -> returnUs (stg_binds, new_env, float_binds)
 149
 150     --------------------
 151     -- HACK: look for very simple, obviously-liftable bindings
 152     -- that can come up to the top level; those that couldn't
 153     -- 'cause they were big-lambda constrained in the Core world.
 154
 155     seek_liftable :: [StgBinding]       -- accumulator...
 156                   -> StgExpr    -- look for top-lev liftables
 157                   -> ([StgBinding], StgExpr)    -- result
 158
 159     seek_liftable acc expr@(StgLet inner_bind body)
 160       | is_liftable inner_bind
 161       = seek_liftable (inner_bind : acc) body
 162
 163     seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
 164
 165     --------------------
 166     is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
 167       = not (null args) -- it's manifestly a function...
 168         || isLeakFreeType [] (idType binder)
 169         || is_whnf body
 170         -- ToDo: use a decent manifestlyWHNF function for STG?
 171       where
 172         is_whnf (StgCon _ _ _)      = True
 173         is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
 174         is_whnf other                       = False
 175
 176     is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
 177       = not (null args) -- it's manifestly a (recursive) function...
 178
 179     is_liftable anything_else = False
 180 \end{code}
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection[coreToStg-binds]{Converting bindings}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 \begin{code}
 189 coreBindToStg :: StgEnv
 190               -> CoreBinding
 191               -> UniqSM ([StgBinding],  -- Empty or singleton
 192                          StgEnv,                -- New envt
 193                          Bag StgBinding)        -- Floats
 194
 195 coreBindToStg env (NonRec binder rhs)
 196   = coreRhsToStg env rhs        `thenUs` \ (stg_rhs, rhs_binds) ->
 197
 198     let
 199         -- Binds to return if RHS is trivial
 200         triv_binds = if isExported binder then
 201                         [StgNonRec binder stg_rhs]      -- Retain it
 202                      else
 203                         []                              -- Discard it
 204     in
 205     case stg_rhs of
 206       StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 207                 -- Trivial RHS, so augment envt, and ditch the binding
 208                 returnUs (triv_binds, new_env, rhs_binds)
 209            where
 210                 new_env = addOneToIdEnv env binder atom
 211
 212       StgRhsCon cc con_id [] ->
 213                 -- Trivial RHS, so augment envt, and ditch the binding
 214                 returnUs (triv_binds, new_env, rhs_binds)
 215            where
 216                 new_env = addOneToIdEnv env binder (StgVarArg con_id)
 217
 218       other ->  -- Non-trivial RHS, so don't augment envt
 219                 returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
 220
 221 coreBindToStg env (Rec pairs)
 222   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
 223     -- (possibly ToDo)
 224     let
 225         (binders, rhss) = unzip pairs
 226     in
 227     mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
 228     returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
 229 \end{code}
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection[coreToStg-rhss]{Converting right hand sides}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 \begin{code}
 239 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
 240
 241 coreRhsToStg env core_rhs
 242   = coreExprToStg env core_rhs  `thenUs` \ (stg_expr, stg_binds) ->
 243
 244     let stg_rhs = case stg_expr of
 245                     StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
 246                         | var1 == var2 -> rhs
 247                         -- This curious stuff is to unravel what a lambda turns into
 248                         -- We have to do it this way, rather than spot a lambda in the
 249                         -- incoming rhs
 250
 251                     StgCon con args _ -> StgRhsCon noCostCentre con args
 252
 253                     other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 254                                            stgArgOcc    -- safe
 255                                            bOGUS_FVs
 256                                            Updatable    -- Be pessimistic
 257                                            []
 258                                            stg_expr
 259     in
 260     returnUs (stg_rhs, stg_binds)
 261 \end{code}
 262
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 \subsection[coreToStg-lits]{Converting literals}
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 Literals: the NoRep kind need to be de-no-rep'd.
 271 We always replace them with a simple variable, and float a suitable
 272 binding out to the top level.
 273
 274 If an Integer is small enough (Haskell implementations must support
 275 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 276 otherwise, wrap with @litString2Integer@.
 277
 278 \begin{code}
 279 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
 280 tARGET_MIN_INT = -536870912
 281 tARGET_MAX_INT =  536870912
 282
 283 litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
 284
 285 litToStgArg (NoRepStr s)
 286   = newStgVar stringTy          `thenUs` \ var ->
 287     let
 288         rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 289                             stgArgOcc    -- safe
 290                             bOGUS_FVs
 291                             Updatable    -- WAS: ReEntrant (see note below)
 292                             []           -- No arguments
 293                             val
 294
 295 -- We used not to update strings, so that they wouldn't clog up the heap,
 296 -- but instead be unpacked each time.  But on some programs that costs a lot
 297 -- [eg hpg], so now we update them.
 298
 299         val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
 300                 StgApp (StgVarArg unpackCString2Id)
 301                      [StgLitArg (MachStr s),
 302                       StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 303                      bOGUS_LVs
 304               else
 305                 StgApp (StgVarArg unpackCStringId)
 306                      [StgLitArg (MachStr s)]
 307                      bOGUS_LVs
 308     in
 309     returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 310   where
 311     is_NUL c = c == '\0'
 312
 313 litToStgArg (NoRepInteger i integer_ty)
 314   -- extremely convenient to look out for a few very common
 315   -- Integer literals!
 316   | i == 0    = returnUs (StgVarArg integerZeroId,     emptyBag)
 317   | i == 1    = returnUs (StgVarArg integerPlusOneId,  emptyBag)
 318   | i == 2    = returnUs (StgVarArg integerPlusTwoId,  emptyBag)
 319   | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
 320
 321   | otherwise
 322   = newStgVar integer_ty        `thenUs` \ var ->
 323     let
 324         rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 325                             stgArgOcc    -- safe
 326                             bOGUS_FVs
 327                             Updatable    -- Update an integer
 328                             []           -- No arguments
 329                             val
 330
 331         val
 332           | i > tARGET_MIN_INT && i < tARGET_MAX_INT
 333           =     -- Start from an Int
 334             StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
 335
 336           | otherwise
 337           =     -- Start from a string
 338             StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
 339     in
 340     returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 341
 342 litToStgArg (NoRepRational r rational_ty)
 343   = --ASSERT(is_rational_ty)
 344     (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
 345     litToStgArg (NoRepInteger (numerator   r) integer_ty) `thenUs` \ (num_atom,   binds1) ->
 346     litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
 347     newStgVar rational_ty                       `thenUs` \ var ->
 348     let
 349          rhs = StgRhsCon noCostCentre   -- No cost centre (ToDo?)
 350                          ratio_data_con -- Constructor
 351                          [num_atom, denom_atom]
 352     in
 353     returnUs (StgVarArg var, binds1 `unionBags`
 354                             binds2 `unionBags`
 355                             unitBag (StgNonRec var rhs))
 356   where
 357     (is_rational_ty, ratio_data_con, integer_ty)
 358       = case (maybeAppDataTyCon rational_ty) of
 359           Just (tycon, [i_ty], [con])
 360             -> ASSERT(is_integer_ty i_ty)
 361                (uniqueOf tycon == ratioTyConKey, con, i_ty)
 362
 363           _ -> (False, panic "ratio_data_con", panic "integer_ty")
 364
 365     is_integer_ty ty
 366       = case (maybeAppDataTyCon ty) of
 367           Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
 368           _ -> False
 369
 370 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection[coreToStg-atoms{Converting atoms}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
 382
 383 coreArgsToStg env [] = returnUs ([], [], emptyBag)
 384 coreArgsToStg env (a:as)
 385   = coreArgsToStg env as    `thenUs` \ (tys, args, binds) ->
 386     do_arg a tys args binds
 387   where
 388     do_arg a trest vrest binds
 389       = case a of
 390           TyArg    t -> returnUs (t:trest, vrest, binds)
 391           UsageArg u -> returnUs (trest, vrest, binds)
 392           VarArg   v -> returnUs (trest, stgLookup env v : vrest, binds)
 393           LitArg   i -> litToStgArg i `thenUs` \ (v, bs) ->
 394                         returnUs (trest, v:vrest, bs `unionBags` binds)
 395 \end{code}
 396
 397 There's not anything interesting we can ASSERT about \tr{var} if it
 398 isn't in the StgEnv. (WDP 94/06)
 399 \begin{code}
 400 stgLookup :: StgEnv -> Id -> StgArg
 401
 402 stgLookup env var = case (lookupIdEnv env var) of
 403                       Nothing   -> StgVarArg var
 404                       Just atom -> atom
 405 \end{code}
 406
 407 %************************************************************************
 408 %*                                                                      *
 409 \subsection[coreToStg-exprs]{Converting core expressions}
 410 %*                                                                      *
 411 %************************************************************************
 412
 413 \begin{code}
 414 coreExprToStg :: StgEnv
 415               -> CoreExpr
 416               -> UniqSM (StgExpr,               -- Result
 417                          Bag StgBinding)        -- Float these to top level
 418 \end{code}
 419
 420 \begin{code}
 421 coreExprToStg env (Lit lit)
 422   = litToStgArg lit     `thenUs` \ (atom, binds) ->
 423     returnUs (StgApp atom [] bOGUS_LVs, binds)
 424
 425 coreExprToStg env (Var var)
 426   = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
 427
 428 coreExprToStg env (Con con args)
 429   = coreArgsToStg env args  `thenUs` \ (types, stg_atoms, stg_binds) ->
 430     let
 431         spec_con = mkSpecialisedCon con types
 432     in
 433     returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
 434
 435 coreExprToStg env (Prim op args)
 436   = coreArgsToStg env args  `thenUs` \ (_, stg_atoms, stg_binds) ->
 437     returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
 438 \end{code}
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 \begin{code}
 447 coreExprToStg env expr@(Lam _ _)
 448   = let
 449         (_,_, binders, body) = collectBinders expr
 450     in
 451     coreExprToStg env body              `thenUs` \ stuff@(stg_body, binds) ->
 452
 453     if null binders then -- it was all type/usage binders; tossed
 454         returnUs stuff
 455     else
 456         newStgVar (coreExprType expr)   `thenUs` \ var ->
 457         returnUs
 458           (StgLet (StgNonRec var (StgRhsClosure noCostCentre
 459                                   stgArgOcc
 460                                   bOGUS_FVs
 461                                   ReEntrant     -- binders is non-empty
 462                                   binders
 463                                   stg_body))
 464            (StgApp (StgVarArg var) [] bOGUS_LVs),
 465            binds)
 466 \end{code}
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsubsection[coreToStg-applications]{Applications}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 \begin{code}
 475 coreExprToStg env expr@(App _ _)
 476   = let
 477         (fun, _, _, args) = collectArgs expr
 478     in
 479         -- Deal with the arguments
 480     coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
 481
 482         -- Now deal with the function
 483     case fun of
 484       Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
 485
 486       other ->  -- A non-variable applied to things; better let-bind it.
 487                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 488                 coreExprToStg env fun           `thenUs` \ (stg_fun, fun_binds) ->
 489                 let
 490                    fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 491                                            stgArgOcc
 492                                            bOGUS_FVs
 493                                            SingleEntry  -- Only entered once
 494                                            []
 495                                            stg_fun
 496                 in
 497                 returnUs (StgLet (StgNonRec fun_id fun_rhs)
 498                                   (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
 499                            arg_binds `unionBags` fun_binds)
 500 \end{code}
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsubsection[coreToStg-cases]{Case expressions}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 At this point, we *mangle* cases involving fork# and par# in the
 509 discriminant.  The original templates for these primops (see
 510 @PrelVals.lhs@) constructed case expressions with boolean results
 511 solely to fool the strictness analyzer, the simplifier, and anyone
 512 else who might want to fool with the evaluation order.  Now, we
 513 believe that once the translation to STG code is performed, our
 514 evaluation order is safe.  Therefore, we convert expressions of the
 515 form:
 516
 517     case par# e of
 518       True -> rhs
 519       False -> parError#
 520
 521 to
 522
 523     case par# e of
 524       _ -> rhs
 525
 526 \begin{code}
 527
 528 coreExprToStg env (Case discrim@(Prim op _) alts)
 529   | funnyParallelOp op
 530   = getUnique                   `thenUs` \ uniq ->
 531     coreExprToStg env discrim   `thenUs` \ (stg_discrim, discrim_binds) ->
 532     alts_to_stg alts            `thenUs` \ (stg_alts, alts_binds) ->
 533     returnUs (
 534         StgCase stg_discrim
 535                 bOGUS_LVs
 536                 bOGUS_LVs
 537                 uniq
 538                 stg_alts,
 539         discrim_binds `unionBags` alts_binds
 540     )
 541   where
 542     funnyParallelOp SeqOp  = True
 543     funnyParallelOp ParOp  = True
 544     funnyParallelOp ForkOp = True
 545     funnyParallelOp _      = False
 546
 547     discrim_ty = coreExprType discrim
 548
 549     alts_to_stg (PrimAlts _ (BindDefault binder rhs))
 550       = coreExprToStg env rhs  `thenUs` \ (stg_rhs, rhs_binds) ->
 551         let
 552             stg_deflt = StgBindDefault binder False stg_rhs
 553         in
 554             returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
 555
 556 -- OK, back to real life...
 557
 558 coreExprToStg env (Case discrim alts)
 559   = coreExprToStg env discrim           `thenUs` \ (stg_discrim, discrim_binds) ->
 560     alts_to_stg discrim alts    `thenUs` \ (stg_alts, alts_binds) ->
 561     getUnique                           `thenUs` \ uniq ->
 562     returnUs (
 563         StgCase stg_discrim
 564                 bOGUS_LVs
 565                 bOGUS_LVs
 566                 uniq
 567                 stg_alts,
 568         discrim_binds `unionBags` alts_binds
 569     )
 570   where
 571     discrim_ty              = coreExprType discrim
 572     (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
 573
 574     alts_to_stg discrim (AlgAlts alts deflt)
 575       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt, deflt_binds) ->
 576         mapAndUnzipUs boxed_alt_to_stg alts     `thenUs` \ (stg_alts, alts_binds)  ->
 577         returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
 578                   deflt_binds `unionBags` unionManyBags alts_binds)
 579       where
 580         boxed_alt_to_stg (con, bs, rhs)
 581           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 582             returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
 583                        rhs_binds)
 584           where
 585             spec_con = mkSpecialisedCon con discrim_ty_args
 586
 587     alts_to_stg discrim (PrimAlts alts deflt)
 588       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt,deflt_binds) ->
 589         mapAndUnzipUs unboxed_alt_to_stg alts   `thenUs` \ (stg_alts, alts_binds)  ->
 590         returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
 591                   deflt_binds `unionBags` unionManyBags alts_binds)
 592       where
 593         unboxed_alt_to_stg (lit, rhs)
 594           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 595             returnUs ((lit, stg_rhs), rhs_binds)
 596
 597     default_to_stg discrim NoDefault
 598       = returnUs (StgNoDefault, emptyBag)
 599
 600     default_to_stg discrim (BindDefault binder rhs)
 601       = coreExprToStg new_env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 602         returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
 603                   rhs_binds)
 604       where
 605         --
 606         -- We convert   case x of {...; x' -> ...x'...}
 607         --      to
 608         --              case x of {...; _  -> ...x... }
 609         --
 610         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 611         -- It's quite easily done: simply extend the environment to bind the
 612         -- default binder to the scrutinee.
 613         --
 614         new_env = case discrim of
 615                     Var v -> addOneToIdEnv env binder (stgLookup env v)
 616                     other   -> env
 617 \end{code}
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626 coreExprToStg env (Let bind body)
 627   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env, float_binds1) ->
 628     coreExprToStg new_env body   `thenUs` \ (stg_body, float_binds2) ->
 629     returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
 630 \end{code}
 631
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsubsection[coreToStg-scc]{SCC expressions}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 Covert core @scc@ expression directly to STG @scc@ expression.
 640 \begin{code}
 641 coreExprToStg env (SCC cc expr)
 642   = coreExprToStg env expr   `thenUs` \ (stg_expr, binds) ->
 643     returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 644 \end{code}
 645
 646 \begin{code}
 647 coreExprToStg env (Coerce c ty expr)
 648   = coreExprToStg env expr  -- `thenUs` \ (stg_expr, binds) ->
 649 --  returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 650 \end{code}
 651
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659 Utilities.
 660
 661 Invent a fresh @Id@:
 662 \begin{code}
 663 newStgVar :: Type -> UniqSM Id
 664 newStgVar ty
 665  = getUnique                    `thenUs` \ uniq ->
 666    returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
 667 \end{code}
 668
 669 \begin{code}
 670 mkStgLets ::   [StgBinding]
 671             -> StgExpr  -- body of let
 672             -> StgExpr
 673
 674 mkStgLets binds body = foldr StgLet body binds
 675 \end{code}