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) = collect_args 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, args) of
 486       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 487                                 -- there are no arguments.
 488                             returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
 489
 490       (non_var_fun, []) ->      -- No value args, so recurse into the function
 491                             coreExprToStg env non_var_fun
 492
 493       other ->  -- A non-variable applied to things; better let-bind it.
 494                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 495                 coreExprToStg env fun           `thenUs` \ (stg_fun, fun_binds) ->
 496                 let
 497                    fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 498                                            stgArgOcc
 499                                            bOGUS_FVs
 500                                            SingleEntry  -- Only entered once
 501                                            []
 502                                            stg_fun
 503                 in
 504                 returnUs (StgLet (StgNonRec fun_id fun_rhs)
 505                                   (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
 506                            arg_binds `unionBags` fun_binds)
 507   where
 508         -- Collect arguments, discarding type/usage applications
 509     collect_args (App e   (TyArg _))    args = collect_args e   args
 510     collect_args (App e   (UsageArg _)) args = collect_args e   args
 511     collect_args (App fun arg)          args = collect_args fun (arg:args)
 512     collect_args fun                    args = (fun, args)
 513 \end{code}
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsubsection[coreToStg-cases]{Case expressions}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 At this point, we *mangle* cases involving fork# and par# in the
 522 discriminant.  The original templates for these primops (see
 523 @PrelVals.lhs@) constructed case expressions with boolean results
 524 solely to fool the strictness analyzer, the simplifier, and anyone
 525 else who might want to fool with the evaluation order.  Now, we
 526 believe that once the translation to STG code is performed, our
 527 evaluation order is safe.  Therefore, we convert expressions of the
 528 form:
 529
 530     case par# e of
 531       True -> rhs
 532       False -> parError#
 533
 534 to
 535
 536     case par# e of
 537       _ -> rhs
 538
 539 \begin{code}
 540
 541 coreExprToStg env (Case discrim@(Prim op _) alts)
 542   | funnyParallelOp op
 543   = getUnique                   `thenUs` \ uniq ->
 544     coreExprToStg env discrim   `thenUs` \ (stg_discrim, discrim_binds) ->
 545     alts_to_stg alts            `thenUs` \ (stg_alts, alts_binds) ->
 546     returnUs (
 547         StgCase stg_discrim
 548                 bOGUS_LVs
 549                 bOGUS_LVs
 550                 uniq
 551                 stg_alts,
 552         discrim_binds `unionBags` alts_binds
 553     )
 554   where
 555     funnyParallelOp SeqOp  = True
 556     funnyParallelOp ParOp  = True
 557     funnyParallelOp ForkOp = True
 558     funnyParallelOp _      = False
 559
 560     discrim_ty = coreExprType discrim
 561
 562     alts_to_stg (PrimAlts _ (BindDefault binder rhs))
 563       = coreExprToStg env rhs  `thenUs` \ (stg_rhs, rhs_binds) ->
 564         let
 565             stg_deflt = StgBindDefault binder False stg_rhs
 566         in
 567             returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
 568
 569 -- OK, back to real life...
 570
 571 coreExprToStg env (Case discrim alts)
 572   = coreExprToStg env discrim           `thenUs` \ (stg_discrim, discrim_binds) ->
 573     alts_to_stg discrim alts    `thenUs` \ (stg_alts, alts_binds) ->
 574     getUnique                           `thenUs` \ uniq ->
 575     returnUs (
 576         StgCase stg_discrim
 577                 bOGUS_LVs
 578                 bOGUS_LVs
 579                 uniq
 580                 stg_alts,
 581         discrim_binds `unionBags` alts_binds
 582     )
 583   where
 584     discrim_ty              = coreExprType discrim
 585     (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
 586
 587     alts_to_stg discrim (AlgAlts alts deflt)
 588       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt, deflt_binds) ->
 589         mapAndUnzipUs boxed_alt_to_stg alts     `thenUs` \ (stg_alts, alts_binds)  ->
 590         returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
 591                   deflt_binds `unionBags` unionManyBags alts_binds)
 592       where
 593         boxed_alt_to_stg (con, bs, rhs)
 594           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 595             returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
 596                        rhs_binds)
 597           where
 598             spec_con = mkSpecialisedCon con discrim_ty_args
 599
 600     alts_to_stg discrim (PrimAlts alts deflt)
 601       = default_to_stg discrim deflt            `thenUs` \ (stg_deflt,deflt_binds) ->
 602         mapAndUnzipUs unboxed_alt_to_stg alts   `thenUs` \ (stg_alts, alts_binds)  ->
 603         returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
 604                   deflt_binds `unionBags` unionManyBags alts_binds)
 605       where
 606         unboxed_alt_to_stg (lit, rhs)
 607           = coreExprToStg env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 608             returnUs ((lit, stg_rhs), rhs_binds)
 609
 610     default_to_stg discrim NoDefault
 611       = returnUs (StgNoDefault, emptyBag)
 612
 613     default_to_stg discrim (BindDefault binder rhs)
 614       = coreExprToStg new_env rhs    `thenUs` \ (stg_rhs, rhs_binds) ->
 615         returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
 616                   rhs_binds)
 617       where
 618         --
 619         -- We convert   case x of {...; x' -> ...x'...}
 620         --      to
 621         --              case x of {...; _  -> ...x... }
 622         --
 623         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 624         -- It's quite easily done: simply extend the environment to bind the
 625         -- default binder to the scrutinee.
 626         --
 627         new_env = case discrim of
 628                     Var v -> addOneToIdEnv env binder (stgLookup env v)
 629                     other   -> env
 630 \end{code}
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 \begin{code}
 639 coreExprToStg env (Let bind body)
 640   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env, float_binds1) ->
 641     coreExprToStg new_env body   `thenUs` \ (stg_body, float_binds2) ->
 642     returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
 643 \end{code}
 644
 645
 646 %************************************************************************
 647 %*                                                                      *
 648 \subsubsection[coreToStg-scc]{SCC expressions}
 649 %*                                                                      *
 650 %************************************************************************
 651
 652 Covert core @scc@ expression directly to STG @scc@ expression.
 653 \begin{code}
 654 coreExprToStg env (SCC cc expr)
 655   = coreExprToStg env expr   `thenUs` \ (stg_expr, binds) ->
 656     returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
 657 \end{code}
 658
 659 \begin{code}
 660 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
 661 \end{code}
 662
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 Utilities.
 671
 672 Invent a fresh @Id@:
 673 \begin{code}
 674 newStgVar :: Type -> UniqSM Id
 675 newStgVar ty
 676  = getUnique                    `thenUs` \ uniq ->
 677    returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
 678 \end{code}
 679
 680 \begin{code}
 681 mkStgLets ::   [StgBinding]
 682             -> StgExpr  -- body of let
 683             -> StgExpr
 684
 685 mkStgLets binds body = foldr StgLet body binds
 686 \end{code}