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