ghc/compiler/stgSyn/CoreToStg.lhs

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