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