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     -- pprTrace "coreBindToStg:" (ppCat [ppr PprDebug binder, ppr PprDebug (isExported binder)]) $
 206     case stg_rhs of
 207       StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 208                 -- Trivial RHS, so augment envt, and ditch the binding
 209                 returnUs (triv_binds, new_env, rhs_binds)
 210            where
 211                 new_env = addOneToIdEnv env binder atom
 212
 213       StgRhsCon cc con_id [] ->
 214                 -- Trivial RHS, so augment envt, and ditch the binding
 215                 returnUs (triv_binds, new_env, rhs_binds)
 216            where
 217                 new_env = addOneToIdEnv env binder (StgVarArg con_id)
 218
 219       other ->  -- Non-trivial RHS, so don't augment envt
 220                 returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
 221
 222 coreBindToStg env (Rec pairs)
 223   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
 224     -- (possibly ToDo)
 225     let
 226         (binders, rhss) = unzip pairs
 227     in
 228     mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
 229     returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection[coreToStg-rhss]{Converting right hand sides}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
 241
 242 coreRhsToStg env core_rhs
 243   = coreExprToStg env core_rhs  `thenUs` \ (stg_expr, stg_binds) ->
 244
 245     let stg_rhs = case stg_expr of
 246                     StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
 247                         | var1 == var2 -> rhs
 248                         -- This curious stuff is to unravel what a lambda turns into
 249                         -- We have to do it this way, rather than spot a lambda in the
 250                         -- incoming rhs
 251
 252                     StgCon con args _ -> StgRhsCon noCostCentre con args
 253
 254                     other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 255                                            stgArgOcc    -- safe
 256                                            bOGUS_FVs
 257                                            Updatable    -- Be pessimistic
 258                                            []
 259                                            stg_expr
 260     in
 261     returnUs (stg_rhs, stg_binds)
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection[coreToStg-lits]{Converting literals}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 Literals: the NoRep kind need to be de-no-rep'd.
 272 We always replace them with a simple variable, and float a suitable
 273 binding out to the top level.
 274
 275 If an Integer is small enough (Haskell implementations must support
 276 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 277 otherwise, wrap with @litString2Integer@.
 278
 279 \begin{code}
 280 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
 281 tARGET_MIN_INT = -536870912
 282 tARGET_MAX_INT =  536870912
 283
 284 litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
 285
 286 litToStgArg (NoRepStr s)
 287   = newStgVar stringTy          `thenUs` \ var ->
 288     let
 289         rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 290                             stgArgOcc    -- safe
 291                             bOGUS_FVs
 292                             Updatable    -- WAS: ReEntrant (see note below)
 293                             []           -- No arguments
 294                             val
 295
 296 -- We used not to update strings, so that they wouldn't clog up the heap,
 297 -- but instead be unpacked each time.  But on some programs that costs a lot
 298 -- [eg hpg], so now we update them.
 299
 300         val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
 301                 StgApp (StgVarArg unpackCString2Id)
 302                      [StgLitArg (MachStr s),
 303                       StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 304                      bOGUS_LVs
 305               else
 306                 StgApp (StgVarArg unpackCStringId)
 307                      [StgLitArg (MachStr s)]
 308                      bOGUS_LVs
 309     in
 310     returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 311   where
 312     is_NUL c = c == '\0'
 313
 314 litToStgArg (NoRepInteger i integer_ty)
 315   -- extremely convenient to look out for a few very common
 316   -- Integer literals!
 317   | i == 0    = returnUs (StgVarArg integerZeroId,     emptyBag)
 318   | i == 1    = returnUs (StgVarArg integerPlusOneId,  emptyBag)
 319   | i == 2    = returnUs (StgVarArg integerPlusTwoId,  emptyBag)
 320   | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
 321
 322   | otherwise
 323   = newStgVar integer_ty        `thenUs` \ var ->
 324     let
 325         rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 326                             stgArgOcc    -- safe
 327                             bOGUS_FVs
 328                             Updatable    -- Update an integer
 329                             []           -- No arguments
 330                             val
 331
 332         val
 333           | i > tARGET_MIN_INT && i < tARGET_MAX_INT
 334           =     -- Start from an Int
 335             StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
 336
 337           | otherwise
 338           =     -- Start from a string
 339             StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
 340     in
 341     returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 342
 343 litToStgArg (NoRepRational r rational_ty)
 344   = --ASSERT(is_rational_ty)
 345     (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
 346     litToStgArg (NoRepInteger (numerator   r) integer_ty) `thenUs` \ (num_atom,   binds1) ->
 347     litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
 348     newStgVar rational_ty                       `thenUs` \ var ->
 349     let
 350          rhs = StgRhsCon noCostCentre   -- No cost centre (ToDo?)
 351                          ratio_data_con -- Constructor
 352                          [num_atom, denom_atom]
 353     in
 354     returnUs (StgVarArg var, binds1 `unionBags`
 355                             binds2 `unionBags`
 356                             unitBag (StgNonRec var rhs))
 357   where
 358     (is_rational_ty, ratio_data_con, integer_ty)
 359       = case (maybeAppDataTyCon rational_ty) of
 360           Just (tycon, [i_ty], [con])
 361             -> ASSERT(is_integer_ty i_ty)
 362                (uniqueOf tycon == ratioTyConKey, con, i_ty)
 363
 364           _ -> (False, panic "ratio_data_con", panic "integer_ty")
 365
 366     is_integer_ty ty
 367       = case (maybeAppDataTyCon ty) of
 368           Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
 369           _ -> False
 370
 371 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
 372 \end{code}
 373
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection[coreToStg-atoms{Converting atoms}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 \begin{code}
 382 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
 383
 384 coreArgsToStg env [] = returnUs ([], [], emptyBag)
 385 coreArgsToStg env (a:as)
 386   = coreArgsToStg env as    `thenUs` \ (tys, args, binds) ->
 387     do_arg a tys args binds
 388   where
 389     do_arg a trest vrest binds
 390       = case a of
 391           TyArg    t -> returnUs (t:trest, vrest, binds)
 392           UsageArg u -> returnUs (trest, vrest, binds)
 393           VarArg   v -> returnUs (trest, stgLookup env v : vrest, binds)
 394           LitArg   i -> litToStgArg i `thenUs` \ (v, bs) ->
 395                         returnUs (trest, v:vrest, bs `unionBags` binds)
 396 \end{code}
 397
 398 There's not anything interesting we can ASSERT about \tr{var} if it
 399 isn't in the StgEnv. (WDP 94/06)
 400 \begin{code}
 401 stgLookup :: StgEnv -> Id -> StgArg
 402
 403 stgLookup env var = case (lookupIdEnv env var) of
 404                       Nothing   -> StgVarArg var
 405                       Just atom -> atom
 406 \end{code}
 407
 408 %************************************************************************
 409 %*                                                                      *
 410 \subsection[coreToStg-exprs]{Converting core expressions}
 411 %*                                                                      *
 412 %************************************************************************
 413
 414 \begin{code}
 415 coreExprToStg :: StgEnv
 416               -> CoreExpr
 417               -> UniqSM (StgExpr,               -- Result
 418                          Bag StgBinding)        -- Float these to top level
 419 \end{code}
 420
 421 \begin{code}
 422 coreExprToStg env (Lit lit)
 423   = litToStgArg lit     `thenUs` \ (atom, binds) ->
 424     returnUs (StgApp atom [] bOGUS_LVs, binds)
 425
 426 coreExprToStg env (Var var)
 427   = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
 428
 429 coreExprToStg env (Con con args)
 430   = coreArgsToStg env args  `thenUs` \ (types, stg_atoms, stg_binds) ->
 431     let
 432         spec_con = mkSpecialisedCon con types
 433     in
 434     returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
 435
 436 coreExprToStg env (Prim op args)
 437   = coreArgsToStg env args  `thenUs` \ (_, stg_atoms, stg_binds) ->
 438     returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
 439 \end{code}
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 \begin{code}
 448 coreExprToStg env expr@(Lam _ _)
 449   = let
 450         (_,_, binders, body) = collectBinders expr
 451     in
 452     coreExprToStg env body              `thenUs` \ stuff@(stg_body, binds) ->
 453
 454     if null binders then -- it was all type/usage binders; tossed
 455         returnUs stuff
 456     else
 457         newStgVar (coreExprType expr)   `thenUs` \ var ->
 458         returnUs
 459           (StgLet (StgNonRec var (StgRhsClosure noCostCentre
 460                                   stgArgOcc
 461                                   bOGUS_FVs
 462                                   ReEntrant     -- binders is non-empty
 463                                   binders
 464                                   stg_body))
 465            (StgApp (StgVarArg var) [] bOGUS_LVs),
 466            binds)
 467 \end{code}
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsubsection[coreToStg-applications]{Applications}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 coreExprToStg env expr@(App _ _)
 477   = let
 478         (fun, _, _, args) = collectArgs expr
 479     in
 480         -- Deal with the arguments
 481     coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
 482
 483         -- Now deal with the function
 484     case fun of
 485       Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
 486
 487       other ->  -- A non-variable applied to things; better let-bind it.
 488                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 489                 coreExprToStg env fun           `thenUs` \ (stg_fun, fun_binds) ->
 490                 let
 491                    fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 492                                            stgArgOcc
 493                                            bOGUS_FVs
 494                                            SingleEntry  -- Only entered once
 495                                            []
 496                                            stg_fun
 497                 in
 498                 returnUs (StgLet (StgNonRec fun_id fun_rhs)
 499                                   (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
 500                            arg_binds `unionBags` fun_binds)
 501 \end{code}
 502
 503 %************************************************************************
 504 %*                                                                      *
 505 \subsubsection[coreToStg-cases]{Case expressions}
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 At this point, we *mangle* cases involving fork# and par# in the
 510 discriminant.  The original templates for these primops (see
 511 @PrelVals.lhs@) constructed case expressions with boolean results
 512 solely to fool the strictness analyzer, the simplifier, and anyone
 513 else who might want to fool with the evaluation order.  Now, we
 514 believe that once the translation to STG code is performed, our
 515 evaluation order is safe.  Therefore, we convert expressions of the
 516 form:
 517
 518     case par# e of
 519       True -> rhs
 520       False -> parError#
 521
 522 to
 523
 524     case par# e of
 525       _ -> rhs
 526
 527 \begin{code}
 528
 529 coreExprToStg env (Case discrim@(Prim op _) alts)
 530   | funnyParallelOp op
 531   = getUnique                   `thenUs` \ uniq ->
 532     coreExprToStg env discrim   `thenUs` \ (stg_discrim, discrim_binds) ->
 533     alts_to_stg alts            `thenUs` \ (stg_alts, alts_binds) ->
 534     returnUs (
 535         StgCase stg_discrim
 536                 bOGUS_LVs
 537                 bOGUS_LVs
 538                 uniq
 539                 stg_alts,
 540         discrim_binds `unionBags` alts_binds
 541     )
 542   where
 543     funnyParallelOp SeqOp  = True
 544     funnyParallelOp ParOp  = True
 545     funnyParallelOp ForkOp = True
 546     funnyParallelOp _      = False
 547
 548     discrim_ty = coreExprType discrim
 549
 550     alts_to_stg (PrimAlts _ (BindDefault binder rhs))
 551       = coreExprToStg env rhs  `thenUs` \ (stg_rhs, rhs_binds) ->
 552         let
 553             stg_deflt = StgBindDefault binder False stg_rhs
 554         in
 555             returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
 556
 557 -- OK, back to real life...
 558
 559 coreExprToStg env (Case discrim alts)
 560   = coreExprToStg env discrim           `thenUs` \ (stg_discrim, discrim_binds) ->
 561     alts_to_stg discrim alts    `thenUs` \ (stg_alts, alts_binds) ->
 562     getUnique                           `thenUs` \ uniq ->
 563     returnUs (
 564         StgCase stg_discrim
 565                 bOGUS_LVs
 566                 bOGUS_LVs
 567                 uniq
 568                 stg_alts,
 569         discrim_binds `unionBags` alts_binds
 570     )
 571   where
 572     discrim_ty              = coreExprType discrim
 573     (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
 574
 575     alts_to_stg discrim (AlgAlts alts deflt)
 576       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt, deflt_binds) ->
 577         mapAndUnzipUs boxed_alt_to_stg alts     `thenUs` \ (stg_alts, alts_binds)  ->
 578         returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
 579                   deflt_binds `unionBags` unionManyBags alts_binds)
 580       where
 581         boxed_alt_to_stg (con, bs, rhs)
 582           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 583             returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
 584                        rhs_binds)
 585           where
 586             spec_con = mkSpecialisedCon con discrim_ty_args
 587
 588     alts_to_stg discrim (PrimAlts alts deflt)
 589       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt,deflt_binds) ->
 590         mapAndUnzipUs unboxed_alt_to_stg alts   `thenUs` \ (stg_alts, alts_binds)  ->
 591         returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
 592                   deflt_binds `unionBags` unionManyBags alts_binds)
 593       where
 594         unboxed_alt_to_stg (lit, rhs)
 595           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 596             returnUs ((lit, stg_rhs), rhs_binds)
 597
 598     default_to_stg discrim NoDefault
 599       = returnUs (StgNoDefault, emptyBag)
 600
 601     default_to_stg discrim (BindDefault binder rhs)
 602       = coreExprToStg new_env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 603         returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
 604                   rhs_binds)
 605       where
 606         --
 607         -- We convert   case x of {...; x' -> ...x'...}
 608         --      to
 609         --              case x of {...; _  -> ...x... }
 610         --
 611         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 612         -- It's quite easily done: simply extend the environment to bind the
 613         -- default binder to the scrutinee.
 614         --
 615         new_env = case discrim of
 616                     Var v -> addOneToIdEnv env binder (stgLookup env v)
 617                     other   -> env
 618 \end{code}
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 \begin{code}
 627 coreExprToStg env (Let bind body)
 628   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env, float_binds1) ->
 629     coreExprToStg new_env body   `thenUs` \ (stg_body, float_binds2) ->
 630     returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
 631 \end{code}
 632
 633
 634 %************************************************************************
 635 %*                                                                      *
 636 \subsubsection[coreToStg-scc]{SCC expressions}
 637 %*                                                                      *
 638 %************************************************************************
 639
 640 Covert core @scc@ expression directly to STG @scc@ expression.
 641 \begin{code}
 642 coreExprToStg env (SCC cc expr)
 643   = coreExprToStg env expr   `thenUs` \ (stg_expr, binds) ->
 644     returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 645 \end{code}
 646
 647 \begin{code}
 648 coreExprToStg env (Coerce c ty expr)
 649   = coreExprToStg env expr  -- `thenUs` \ (stg_expr, binds) ->
 650 --  returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 651 \end{code}
 652
 653
 654 %************************************************************************
 655 %*                                                                      *
 656 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 657 %*                                                                      *
 658 %************************************************************************
 659
 660 Utilities.
 661
 662 Invent a fresh @Id@:
 663 \begin{code}
 664 newStgVar :: Type -> UniqSM Id
 665 newStgVar ty
 666  = getUnique                    `thenUs` \ uniq ->
 667    returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
 668 \end{code}
 669
 670 \begin{code}
 671 mkStgLets ::   [StgBinding]
 672             -> StgExpr  -- body of let
 673             -> StgExpr
 674
 675 mkStgLets binds body = foldr StgLet body binds
 676 \end{code}