ghc/compiler/codeGen/CgCase.lhs

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