ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.55 2001/12/05 17:35:13 sewardj Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgCase]{Converting @StgCase@ expressions}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
  14         ) where
  15
  16 #include "HsVersions.h"
  17
  18 import {-# SOURCE #-} CgExpr  ( cgExpr )
  19
  20 import CgMonad
  21 import StgSyn
  22 import AbsCSyn
  23
  24 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
  25                           getAmodeRep, nonemptyAbsC
  26                         )
  27 import CgUpdate         ( reserveSeqFrame )
  28 import CgBindery        ( getVolatileRegs, getArgAmodes,
  29                           bindNewToReg, bindNewToTemp,
  30                           bindNewPrimToAmode, getCAddrModeAndInfo,
  31                           rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
  32                           buildContLivenessMask, nukeDeadBindings,
  33                         )
  34 import CgCon            ( bindConArgs, bindUnboxedTupleComponents )
  35 import CgHeapery        ( altHeapCheck )
  36 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg,
  37                           CtrlReturnConvention(..)
  38                         )
  39 import CgStackery       ( allocPrimStack, allocStackTop,
  40                           deAllocStackTop, freeStackSlots, dataStackSlots
  41                         )
  42 import CgTailCall       ( tailCallFun )
  43 import CgUsages         ( getSpRelOffset )
  44 import CLabel           ( mkVecTblLabel, mkClosureTblLabel,
  45                           mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
  46                         )
  47 import ClosureInfo      ( mkLFArgument )
  48 import CmdLineOpts      ( opt_SccProfilingOn )
  49 import Id               ( Id, idPrimRep, isDeadBinder )
  50 import DataCon          ( DataCon, dataConTag, fIRST_TAG, ConTag )
  51 import VarSet           ( varSetElems )
  52 import Literal          ( Literal )
  53 import PrimOp           ( primOpOutOfLine, PrimOp(..) )
  54 import PrimRep          ( getPrimRepSize, retPrimRepSize, PrimRep(..)
  55                         )
  56 import TyCon            ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
  57 import Unique           ( Unique, Uniquable(..), newTagUnique )
  58 import Maybes           ( maybeToBool )
  59 import Util             ( only )
  60 import Outputable
  61 \end{code}
  62
  63 \begin{code}
  64 data GCFlag
  65   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  66                 -- tidy before the code for the scrutinee.
  67
  68   | NoGC        -- The scrutinee is a primitive value, or a call to a
  69                 -- primitive op which does no GC.  Hence the case can
  70                 -- be done inline, without tidying up first.
  71 \end{code}
  72
  73 It is quite interesting to decide whether to put a heap-check
  74 at the start of each alternative.  Of course we certainly have
  75 to do so if the case forces an evaluation, or if there is a primitive
  76 op which can trigger GC.
  77
  78 A more interesting situation is this:
  79
  80  \begin{verbatim}
  81         !A!;
  82         ...A...
  83         case x# of
  84           0#      -> !B!; ...B...
  85           default -> !C!; ...C...
  86  \end{verbatim}
  87
  88 where \tr{!x!} indicates a possible heap-check point. The heap checks
  89 in the alternatives {\em can} be omitted, in which case the topmost
  90 heapcheck will take their worst case into account.
  91
  92 In favour of omitting \tr{!B!}, \tr{!C!}:
  93
  94  - {\em May} save a heap overflow test,
  95         if ...A... allocates anything.  The other advantage
  96         of this is that we can use relative addressing
  97         from a single Hp to get at all the closures so allocated.
  98
  99  - No need to save volatile vars etc across the case
 100
 101 Against:
 102
 103   - May do more allocation than reqd.  This sometimes bites us
 104         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 105         worst-casing is done, because many many calls to nfib are leaf calls
 106         which don't need to allocate anything.
 107
 108         This never hurts us if there is only one alternative.
 109
 110 \begin{code}
 111 cgCase  :: StgExpr
 112         -> StgLiveVars
 113         -> StgLiveVars
 114         -> Id
 115         -> SRT
 116         -> StgCaseAlts
 117         -> Code
 118 \end{code}
 119
 120 Special case #1:  PrimOps returning enumeration types.
 121
 122 For enumeration types, we invent a temporary (builtin-unique 1) to
 123 hold the tag, and cross our fingers that this doesn't clash with
 124 anything else.  Builtin-unique 0 is used for a similar reason when
 125 compiling enumerated-type primops in CgExpr.lhs.  We can't use the
 126 unique from the case binder, because this is used to hold the actual
 127 closure (when the case binder is live, that is).
 128
 129 There is an extra special case for
 130
 131         case tagToEnum# x of
 132                 ...
 133
 134 which generates no code for the primop, unless x is used in the
 135 alternatives (in which case we lookup the tag in the relevant closure
 136 table to get the closure).
 137
 138 Being a bit short of uniques for temporary variables here, we use
 139 newTagUnique to generate a new unique from the case binder.  The case
 140 binder's unique will presumably have the 'c' tag (generated by
 141 CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
 142 doesn't clash with anything else.
 143
 144 \begin{code}
 145 cgCase (StgOpApp op args _)
 146        live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
 147   | isEnumerationTyCon tycon
 148   = getArgAmodes args `thenFC` \ arg_amodes ->
 149
 150     case op of {
 151         StgPrimOp TagToEnumOp   -- No code!
 152            -> returnFC (only arg_amodes) ;
 153
 154         _  ->           -- Perform the operation
 155               let
 156                 tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
 157               in
 158               getVolatileRegs live_in_alts                      `thenFC` \ vol_regs ->
 159               absC (COpStmt [tag_amode] op arg_amodes vol_regs)
 160                                                                 `thenC`
 161                                 -- NB: no liveness arg
 162               returnFC tag_amode
 163     }                                           `thenFC` \ tag_amode ->
 164
 165     let
 166         closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
 167                                tag_amode PtrRep)
 168                        PtrRep
 169     in
 170
 171         -- Bind the default binder if necessary
 172         -- The deadness info is set by StgVarInfo
 173     (if (isDeadBinder bndr)
 174         then nopC
 175         else bindNewToTemp bndr                 `thenFC` \ bndr_amode ->
 176              absC (CAssign bndr_amode closure))
 177                                                 `thenC`
 178
 179         -- compile the alts
 180     cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
 181                 False{-not poly case-} alts deflt
 182                 False{-don't emit yield-}       `thenFC` \ (tagged_alts, deflt_c) ->
 183
 184         -- Do the switch
 185     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 186 \end{code}
 187
 188 Special case #2: inline PrimOps.
 189
 190 \begin{code}
 191 cgCase (StgOpApp op@(StgPrimOp primop) args _)
 192        live_in_whole_case live_in_alts bndr srt alts
 193   | not (primOpOutOfLine primop)
 194   =
 195         -- Get amodes for the arguments and results
 196     getArgAmodes args                   `thenFC` \ arg_amodes ->
 197     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 198
 199     case alts of
 200       StgPrimAlts tycon alts deflt      -- PRIMITIVE ALTS
 201         -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
 202                          op
 203                          arg_amodes     -- note: no liveness arg
 204                          vol_regs)              `thenC`
 205            cgPrimInlineAlts bndr tycon alts deflt
 206
 207       StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
 208         |  isUnboxedTupleTyCon tycon    -- UNBOXED TUPLE ALTS
 209         ->      -- no heap check, no yield, just get in there and do it.
 210            absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
 211                          op
 212                          arg_amodes      -- note: no liveness arg
 213                          vol_regs)              `thenC`
 214            mapFCs bindNewToTemp args `thenFC` \ _ ->
 215            cgExpr rhs
 216
 217       other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
 218 \end{code}
 219
 220 TODO: Case-of-case of primop can probably be done inline too (but
 221 maybe better to translate it out beforehand).  See
 222 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
 223 4.02).
 224
 225 Another special case: scrutinising a primitive-typed variable.  No
 226 evaluation required.  We don't save volatile variables, nor do we do a
 227 heap-check in the alternatives.  Instead, the heap usage of the
 228 alternatives is worst-cased and passed upstream.  This can result in
 229 allocating more heap than strictly necessary, but it will sometimes
 230 eliminate a heap check altogether.
 231
 232 \begin{code}
 233 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 234                         (StgPrimAlts tycon alts deflt)
 235
 236   =
 237     getCAddrMode v              `thenFC` \amode ->
 238
 239     {-
 240        Careful! we can't just bind the default binder to the same thing
 241        as the scrutinee, since it might be a stack location, and having
 242        two bindings pointing at the same stack locn doesn't work (it
 243        confuses nukeDeadBindings).  Hence, use a new temp.
 244     -}
 245     bindNewToTemp bndr                  `thenFC`  \deflt_amode ->
 246     absC (CAssign deflt_amode amode)    `thenC`
 247
 248     cgPrimAlts NoGC amode alts deflt []
 249 \end{code}
 250
 251 Special case: scrutinising a non-primitive variable.
 252 This can be done a little better than the general case, because
 253 we can reuse/trim the stack slot holding the variable (if it is in one).
 254
 255 \begin{code}
 256 cgCase (StgApp fun args)
 257         live_in_whole_case live_in_alts bndr srt alts
 258   = getCAddrModeAndInfo fun                     `thenFC` \ (fun', fun_amode, lf_info) ->
 259     getArgAmodes args                           `thenFC` \ arg_amodes ->
 260
 261        -- Squish the environment
 262     nukeDeadBindings live_in_alts       `thenC`
 263     saveVolatileVarsAndRegs live_in_alts
 264                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 265
 266     allocStackTop retPrimRepSize        `thenFC` \_ ->
 267
 268     forkEval alts_eob_info nopC (
 269              deAllocStackTop retPrimRepSize `thenFC` \_ ->
 270              cgEvalAlts maybe_cc_slot bndr srt alts)
 271                                          `thenFC` \ scrut_eob_info ->
 272
 273     setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info)        $
 274     tailCallFun fun' fun_amode lf_info arg_amodes save_assts
 275 \end{code}
 276
 277 Note about return addresses: we *always* push a return address, even
 278 if because of an optimisation we end up jumping direct to the return
 279 code (not through the address itself).  The alternatives always assume
 280 that the return address is on the stack.  The return address is
 281 required in case the alternative performs a heap check, since it
 282 encodes the liveness of the slots in the activation record.
 283
 284 On entry to the case alternative, we can re-use the slot containing
 285 the return address immediately after the heap check.  That's what the
 286 deAllocStackTop call is doing above.
 287
 288 Finally, here is the general case.
 289
 290 \begin{code}
 291 cgCase expr live_in_whole_case live_in_alts bndr srt alts
 292   =     -- Figure out what volatile variables to save
 293     nukeDeadBindings live_in_whole_case `thenC`
 294
 295     saveVolatileVarsAndRegs live_in_alts
 296                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 297
 298     -- Save those variables right now!
 299     absC save_assts                     `thenC`
 300
 301     -- generate code for the alts
 302     forkEval alts_eob_info
 303         (nukeDeadBindings live_in_alts `thenC`
 304          allocStackTop retPrimRepSize   -- space for retn address
 305          `thenFC` \_ -> nopC
 306          )
 307         (deAllocStackTop retPrimRepSize `thenFC` \_ ->
 308          cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
 309
 310     setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
 311     cgExpr expr
 312 \end{code}
 313
 314 There's a lot of machinery going on behind the scenes to manage the
 315 stack pointer here.  forkEval takes the virtual Sp and free list from
 316 the first argument, and turns that into the *real* Sp for the second
 317 argument.  It also uses this virtual Sp as the args-Sp in the EOB info
 318 returned, so that the scrutinee will trim the real Sp back to the
 319 right place before doing whatever it does.
 320   --SDM (who just spent an hour figuring this out, and didn't want to
 321          forget it).
 322
 323 Why don't we push the return address just before evaluating the
 324 scrutinee?  Because the slot reserved for the return address might
 325 contain something useful, so we wait until performing a tail call or
 326 return before pushing the return address (see
 327 CgTailCall.pushReturnAddress).
 328
 329 This also means that the environment doesn't need to know about the
 330 free stack slot for the return address (for generating bitmaps),
 331 because we don't reserve it until just before the eval.
 332
 333 TODO!!  Problem: however, we have to save the current cost centre
 334 stack somewhere, because at the eval point the current CCS might be
 335 different.  So we pick a free stack slot and save CCCS in it.  The
 336 problem with this is that this slot isn't recorded as free/unboxed in
 337 the environment, so a case expression in the scrutinee will have the
 338 wrong bitmap attached.  Fortunately we don't ever seem to see
 339 case-of-case at the back end.  One solution might be to shift the
 340 saved CCS to the correct place in the activation record just before
 341 the jump.
 342         --SDM
 343
 344 (one consequence of the above is that activation records on the stack
 345 don't follow the layout of closures when we're profiling.  The CCS
 346 could be anywhere within the record).
 347
 348 \begin{code}
 349 -- We need to reserve a seq frame for a polymorphic case
 350 maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
 351 maybeReserveSeqFrame other                    scrut_eob_info = scrut_eob_info
 352 \end{code}
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection[CgCase-alts]{Alternatives}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 @cgEvalAlts@ returns an addressing mode for a continuation for the
 361 alternatives of a @case@, used in a context when there
 362 is some evaluation to be done.
 363
 364 \begin{code}
 365 cgEvalAlts :: Maybe VirtualSpOffset     -- Offset of cost-centre to be restored, if any
 366            -> Id
 367            -> SRT                       -- SRT for the continuation
 368            -> StgCaseAlts
 369            -> FCode Sequel      -- Any addr modes inside are guaranteed
 370                                 -- to be a label so that we can duplicate it
 371                                 -- without risk of duplicating code
 372
 373 cgEvalAlts cc_slot bndr srt alts
 374   =
 375     let uniq = getUnique bndr in
 376
 377     buildContLivenessMask uniq          `thenFC` \ liveness_mask ->
 378
 379     case alts of
 380
 381       -- algebraic alts ...
 382       StgAlgAlts maybe_tycon alts deflt ->
 383
 384            -- bind the default binder (it covers all the alternatives)
 385         bindNewToReg bndr node mkLFArgument      `thenC`
 386
 387         -- Generate sequel info for use downstream
 388         -- At the moment, we only do it if the type is vector-returnable.
 389         -- Reason: if not, then it costs extra to label the
 390         -- alternatives, because we'd get return code like:
 391         --
 392         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 393         --
 394         -- which is worse than having the alt code in the switch statement
 395
 396         let     is_alg          = maybeToBool maybe_tycon
 397                 Just spec_tycon = maybe_tycon
 398         in
 399
 400         -- Deal with the unboxed tuple case
 401         if is_alg && isUnboxedTupleTyCon spec_tycon then
 402                 -- By now, the simplifier should have have turned it
 403                 -- into         case e of (# a,b #) -> e
 404                 -- There shouldn't be a
 405                 --              case e of DEFAULT -> e
 406             ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
 407                      text "cgEvalAlts: dodgy case of unboxed tuple type" )
 408             let
 409                 alt = head alts
 410                 lbl = mkReturnInfoLabel uniq
 411             in
 412             cgUnboxedTupleAlt uniq cc_slot True alt             `thenFC` \ abs_c ->
 413             getSRTInfo srt                                      `thenFC` \ srt_info ->
 414             absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
 415             returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 416
 417         -- normal algebraic (or polymorphic) case alternatives
 418         else let
 419                 ret_conv | is_alg    = ctrlReturnConvAlg spec_tycon
 420                          | otherwise = UnvectoredReturn 0
 421
 422                 use_labelled_alts = case ret_conv of
 423                                         VectoredReturn _ -> True
 424                                         _                -> False
 425
 426                 semi_tagged_stuff
 427                    = if use_labelled_alts then
 428                         cgSemiTaggedAlts bndr alts deflt -- Just <something>
 429                      else
 430                         Nothing -- no semi-tagging info
 431
 432         in
 433         cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
 434                 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 435
 436         mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
 437                 ret_conv  `thenFC` \ return_vec ->
 438
 439         returnFC (CaseAlts return_vec semi_tagged_stuff)
 440
 441       -- primitive alts...
 442       StgPrimAlts tycon alts deflt ->
 443
 444         -- Restore the cost centre
 445         restoreCurrentCostCentre cc_slot                `thenFC` \ cc_restore ->
 446
 447         -- Generate the switch
 448         getAbsC (cgPrimEvalAlts bndr tycon alts deflt)  `thenFC` \ abs_c ->
 449
 450         -- Generate the labelled block, starting with restore-cost-centre
 451         getSRTInfo srt                                  `thenFC` \srt_info ->
 452         absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
 453                          srt_info liveness_mask)        `thenC`
 454
 455         -- Return an amode for the block
 456         returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 457 \end{code}
 458
 459
 460 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 461 we  do  an inlining of the  case  no separate  functions  for returning are
 462 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 463 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 464 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 465
 466 %************************************************************************
 467 %*                                                                      *
 468 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 469 %*                                                                      *
 470 %************************************************************************
 471
 472 In @cgAlgAlts@, none of the binders in the alternatives are
 473 assumed to be yet bound.
 474
 475 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 476 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 477 beginning of  each alternative. Normally we  want that. The  only exception
 478 are inlined alternatives.
 479
 480 \begin{code}
 481 cgAlgAlts :: GCFlag
 482           -> Unique
 483           -> Maybe VirtualSpOffset
 484           -> Bool                               -- True <=> branches must be labelled
 485           -> Bool                               -- True <=> polymorphic case
 486           -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
 487           -> StgCaseDefault                     -- The default
 488           -> Bool                               -- Context switch at alts?
 489           -> FCode ([(ConTag, AbstractC)],      -- The branches
 490                     AbstractC                   -- The default case
 491              )
 492
 493 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
 494           emit_yield{-should a yield macro be emitted?-}
 495
 496   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 497              (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
 498 \end{code}
 499
 500 \begin{code}
 501 cgAlgDefault :: GCFlag
 502              -> Bool                    -- could be a function-typed result?
 503              -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
 504              -> StgCaseDefault          -- input
 505              -> Bool
 506              -> FCode AbstractC         -- output
 507
 508 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
 509   = returnFC AbsCNop
 510
 511 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
 512              (StgBindDefault rhs)
 513           emit_yield{-should a yield macro be emitted?-}
 514
 515   =     -- We have arranged that Node points to the thing
 516     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 517     getAbsC (absC restore_cc `thenC`
 518              -- HWL: maybe need yield here
 519              --(if emit_yield
 520              --   then yield [node] True
 521              --   else absC AbsCNop)                            `thenC`
 522              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 523         -- Node is live, but doesn't need to point at the thing itself;
 524         -- it's ok for Node to point to an indirection or FETCH_ME
 525         -- Hence no need to re-enter Node.
 526     )                                   `thenFC` \ abs_c ->
 527
 528     let
 529         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 530                     | otherwise         = abs_c
 531     in
 532     returnFC final_abs_c
 533   where
 534     lbl = mkDefaultLabel uniq
 535
 536 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 537
 538 cgAlgAlt :: GCFlag
 539          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 540          -> Bool                               -- Context switch at alts?
 541          -> (DataCon, [Id], [Bool], StgExpr)
 542          -> FCode (ConTag, AbstractC)
 543
 544 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 545          emit_yield{-should a yield macro be emitted?-}
 546          (con, args, use_mask, rhs)
 547   =
 548     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 549     getAbsC (absC restore_cc `thenC`
 550              -- HWL: maybe need yield here
 551              -- (if emit_yield
 552              --    then yield [node] True               -- XXX live regs wrong
 553              --    else absC AbsCNop)                               `thenC`
 554              (case gc_flag of
 555                 NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
 556                 GCMayHappen -> bindConArgs con args
 557              )  `thenC`
 558              possibleHeapCheck gc_flag False [node] [] Nothing (
 559              cgExpr rhs)
 560             ) `thenFC` \ abs_c ->
 561     let
 562         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 563                     | otherwise         = abs_c
 564     in
 565     returnFC (tag, final_abs_c)
 566   where
 567     tag = dataConTag con
 568     lbl = mkAltLabel uniq tag
 569
 570 cgUnboxedTupleAlt
 571         :: Unique                       -- unique for label of the alternative
 572         -> Maybe VirtualSpOffset        -- Restore cost centre
 573         -> Bool                         -- ctxt switch
 574         -> (DataCon, [Id], [Bool], StgExpr) -- alternative
 575         -> FCode AbstractC
 576
 577 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
 578   = getAbsC (
 579         bindUnboxedTupleComponents args
 580                       `thenFC` \ (live_regs,tags,stack_res) ->
 581
 582         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 583         absC restore_cc `thenC`
 584
 585         -- HWL: maybe need yield here
 586         -- (if emit_yield
 587         --    then yield live_regs True         -- XXX live regs wrong?
 588         --    else absC AbsCNop)                         `thenC`
 589         let
 590               -- ToDo: could maybe use Nothing here if stack_res is False
 591               -- since the heap-check can just return to the top of the
 592               -- stack.
 593               ret_addr = Just lbl
 594         in
 595
 596         -- free up stack slots containing tags,
 597         freeStackSlots (map fst tags)           `thenC`
 598
 599         -- generate a heap check if necessary
 600         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 601
 602         -- and finally the code for the alternative
 603         cgExpr rhs)
 604     )
 605 \end{code}
 606
 607 %************************************************************************
 608 %*                                                                      *
 609 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 610 %*                                                                      *
 611 %************************************************************************
 612
 613 Turgid-but-non-monadic code to conjure up the required info from
 614 algebraic case alternatives for semi-tagging.
 615
 616 \begin{code}
 617 cgSemiTaggedAlts :: Id
 618                  -> [(DataCon, [Id], [Bool], StgExpr)]
 619                  -> GenStgCaseDefault Id Id
 620                  -> SemiTaggingStuff
 621
 622 cgSemiTaggedAlts binder alts deflt
 623   = Just (map st_alt alts, st_deflt deflt)
 624   where
 625     uniq        = getUnique binder
 626
 627     st_deflt StgNoDefault = Nothing
 628
 629     st_deflt (StgBindDefault _)
 630       = Just (Just binder,
 631               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 632                mkDefaultLabel uniq)
 633              )
 634
 635     st_alt (con, args, use_mask, _)
 636       =  -- Ha!  Nothing to do; Node already points to the thing
 637          (con_tag,
 638            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 639                 [mkIntCLit (length args)], -- how big the thing in the heap is
 640              join_label)
 641             )
 642       where
 643         con_tag     = dataConTag con
 644         join_label  = mkAltLabel uniq con_tag
 645 \end{code}
 646
 647 %************************************************************************
 648 %*                                                                      *
 649 \subsection[CgCase-prim-alts]{Primitive alternatives}
 650 %*                                                                      *
 651 %************************************************************************
 652
 653 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 654 for dealing with the alternatives of a primitive @case@, given an
 655 addressing mode for the thing to scrutinise.  It also keeps track of
 656 the maximum stack depth encountered down any branch.
 657
 658 As usual, no binders in the alternatives are yet bound.
 659
 660 \begin{code}
 661 cgPrimInlineAlts bndr tycon alts deflt
 662   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 663   where
 664         uniq = getUnique bndr
 665         kind = tyConPrimRep tycon
 666
 667 cgPrimEvalAlts bndr tycon alts deflt
 668   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 669   where
 670         reg  = WARN( case kind of { PtrRep -> True; other -> False },
 671                      text "cgPrimEE" <+> ppr bndr <+> ppr tycon  )
 672                dataReturnConvPrim kind
 673         kind = tyConPrimRep tycon
 674
 675 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 676   =     -- first bind the default if necessary
 677     bindNewPrimToAmode bndr scrutinee           `thenC`
 678     cgPrimAlts gc_flag scrutinee alts deflt regs
 679
 680 cgPrimAlts gc_flag scrutinee alts deflt regs
 681   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 682              (cgPrimDefault gc_flag regs deflt)
 683                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 684
 685     absC (CSwitch scrutinee alt_absCs deflt_absC)
 686         -- CSwitch does sensible things with one or zero alternatives
 687
 688
 689 cgPrimAlt :: GCFlag
 690           -> [MagicId]                  -- live registers
 691           -> (Literal, StgExpr)         -- The alternative
 692           -> FCode (Literal, AbstractC) -- Its compiled form
 693
 694 cgPrimAlt gc_flag regs (lit, rhs)
 695   = getAbsC rhs_code     `thenFC` \ absC ->
 696     returnFC (lit,absC)
 697   where
 698     rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
 699
 700 cgPrimDefault :: GCFlag
 701               -> [MagicId]              -- live registers
 702               -> StgCaseDefault
 703               -> FCode AbstractC
 704
 705 cgPrimDefault gc_flag regs StgNoDefault
 706   = panic "cgPrimDefault: No default in prim case"
 707
 708 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 709   = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 \begin{code}
 720 saveVolatileVarsAndRegs
 721     :: StgLiveVars                    -- Vars which should be made safe
 722     -> FCode (AbstractC,              -- Assignments to do the saves
 723               EndOfBlockInfo,         -- sequel for the alts
 724               Maybe VirtualSpOffset)  -- Slot for current cost centre
 725
 726
 727 saveVolatileVarsAndRegs vars
 728   = saveVolatileVars vars       `thenFC` \ var_saves ->
 729     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 730     getEndOfBlockInfo           `thenFC` \ eob_info ->
 731     returnFC (mkAbstractCs [var_saves, cc_save],
 732               eob_info,
 733               maybe_cc_slot)
 734
 735
 736 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 737                  -> FCode AbstractC     -- Assignments to to the saves
 738
 739 saveVolatileVars vars
 740   = save_em (varSetElems vars)
 741   where
 742     save_em [] = returnFC AbsCNop
 743
 744     save_em (var:vars)
 745       = getCAddrModeIfVolatile var `thenFC` \ v ->
 746         case v of
 747             Nothing         -> save_em vars -- Non-volatile, so carry on
 748
 749
 750             Just vol_amode  ->  -- Aha! It's volatile
 751                                save_var var vol_amode   `thenFC` \ abs_c ->
 752                                save_em vars             `thenFC` \ abs_cs ->
 753                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 754
 755     save_var var vol_amode
 756       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 757         rebindToStack var slot          `thenC`
 758         getSpRelOffset slot             `thenFC` \ sp_rel ->
 759         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 760       where
 761         kind = getAmodeRep vol_amode
 762 \end{code}
 763
 764 ---------------------------------------------------------------------------
 765
 766 When we save the current cost centre (which is done for lexical
 767 scoping), we allocate a free stack location, and return (a)~the
 768 virtual offset of the location, to pass on to the alternatives, and
 769 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 770
 771 \begin{code}
 772 saveCurrentCostCentre ::
 773         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 774                AbstractC)               -- Assignment to save it
 775
 776 saveCurrentCostCentre
 777   = if not opt_SccProfilingOn then
 778         returnFC (Nothing, AbsCNop)
 779     else
 780         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 781         dataStackSlots [slot]                         `thenC`
 782         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 783         returnFC (Just slot,
 784                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 785
 786 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 787 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 788 restoreCurrentCostCentre (Just slot)
 789  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 790    freeStackSlots [slot]                         `thenC`
 791    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 792     -- we use the RESTORE_CCCS macro, rather than just
 793     -- assigning into CurCostCentre, in case RESTORE_CCCS
 794     -- has some sanity-checking in it.
 795 \end{code}
 796
 797 %************************************************************************
 798 %*                                                                      *
 799 \subsection[CgCase-return-vec]{Building a return vector}
 800 %*                                                                      *
 801 %************************************************************************
 802
 803 Build a return vector, and return a suitable label addressing
 804 mode for it.
 805
 806 \begin{code}
 807 mkReturnVector :: Unique
 808                -> [(ConTag, AbstractC)] -- Branch codes
 809                -> AbstractC             -- Default case
 810                -> SRT                   -- continuation's SRT
 811                -> Liveness              -- stack liveness
 812                -> CtrlReturnConvention
 813                -> FCode CAddrMode
 814
 815 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 816   = getSRTInfo srt              `thenFC` \ srt_info ->
 817     let
 818      (return_vec_amode, vtbl_body) = case ret_conv of {
 819
 820         -- might be a polymorphic case...
 821       UnvectoredReturn 0 ->
 822         ASSERT(null tagged_alt_absCs)
 823         (CLbl ret_label RetRep,
 824          absC (CRetDirect uniq deflt_absC srt_info liveness));
 825
 826       UnvectoredReturn n ->
 827         -- find the tag explicitly rather than using tag_reg for now.
 828         -- on architectures with lots of regs the tag will be loaded
 829         -- into tag_reg by the code doing the returning.
 830         let
 831           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 832         in
 833         (CLbl ret_label RetRep,
 834          absC (CRetDirect uniq
 835                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 836                             srt_info
 837                             liveness));
 838
 839       VectoredReturn table_size ->
 840         let
 841           (vector_table, alts_absC) =
 842             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 843
 844           ret_vector = CRetVector vtbl_label vector_table srt_info liveness
 845         in
 846         (CLbl vtbl_label DataPtrRep,
 847          -- alts come first, because we don't want to declare all the symbols
 848          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 849         )
 850
 851     } in
 852     vtbl_body                                               `thenC`
 853     returnFC return_vec_amode
 854     -- )
 855   where
 856
 857     vtbl_label = mkVecTblLabel uniq
 858     ret_label = mkReturnInfoLabel uniq
 859
 860     deflt_lbl =
 861         case nonemptyAbsC deflt_absC of
 862                  -- the simplifier might have eliminated a case
 863            Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
 864            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 865
 866     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 867     mk_vector_entry tag
 868       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 869              []     -> (deflt_lbl, AbsCNop)
 870              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 871              _      -> panic "mkReturnVector: too many"
 872 \end{code}
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection[CgCase-utils]{Utilities for handling case expressions}
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 881 heap check or not.  These heap checks are always in a case
 882 alternative, so we use altHeapCheck.
 883
 884 \begin{code}
 885 possibleHeapCheck
 886         :: GCFlag
 887         -> Bool                         --  True <=> algebraic case
 888         -> [MagicId]                    --  live registers
 889         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 890         -> Maybe Unique                 --  return address unique
 891         -> Code                         --  continuation
 892         -> Code
 893
 894 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
 895   = altHeapCheck is_alg regs tags AbsCNop lbl code
 896 possibleHeapCheck NoGC  _ _ tags lbl code
 897   = code
 898 \end{code}