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