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