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