ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.53 2001/09/26 15:11:50 simonpj 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             case alts of
 402                 [alt] -> let lbl = mkReturnInfoLabel uniq in
 403                          cgUnboxedTupleAlt uniq cc_slot True alt
 404                                 `thenFC` \ abs_c ->
 405                          getSRTInfo srt          `thenFC` \ srt_info ->
 406                          absC (CRetDirect uniq abs_c srt_info
 407                                         liveness_mask) `thenC`
 408                         returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 409                 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
 410
 411         -- normal algebraic (or polymorphic) case alternatives
 412         else let
 413                 ret_conv | is_alg    = ctrlReturnConvAlg spec_tycon
 414                          | otherwise = UnvectoredReturn 0
 415
 416                 use_labelled_alts = case ret_conv of
 417                                         VectoredReturn _ -> True
 418                                         _                -> False
 419
 420                 semi_tagged_stuff
 421                    = if use_labelled_alts then
 422                         cgSemiTaggedAlts bndr alts deflt -- Just <something>
 423                      else
 424                         Nothing -- no semi-tagging info
 425
 426         in
 427         cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
 428                 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 429
 430         mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
 431                 ret_conv  `thenFC` \ return_vec ->
 432
 433         returnFC (CaseAlts return_vec semi_tagged_stuff)
 434
 435       -- primitive alts...
 436       StgPrimAlts tycon alts deflt ->
 437
 438         -- Restore the cost centre
 439         restoreCurrentCostCentre cc_slot                `thenFC` \ cc_restore ->
 440
 441         -- Generate the switch
 442         getAbsC (cgPrimEvalAlts bndr tycon alts deflt)  `thenFC` \ abs_c ->
 443
 444         -- Generate the labelled block, starting with restore-cost-centre
 445         getSRTInfo srt                                  `thenFC` \srt_info ->
 446         absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
 447                          srt_info liveness_mask)        `thenC`
 448
 449         -- Return an amode for the block
 450         returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 451 \end{code}
 452
 453
 454 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 455 we  do  an inlining of the  case  no separate  functions  for returning are
 456 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 457 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 458 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 In @cgAlgAlts@, none of the binders in the alternatives are
 467 assumed to be yet bound.
 468
 469 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 470 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 471 beginning of  each alternative. Normally we  want that. The  only exception
 472 are inlined alternatives.
 473
 474 \begin{code}
 475 cgAlgAlts :: GCFlag
 476           -> Unique
 477           -> Maybe VirtualSpOffset
 478           -> Bool                               -- True <=> branches must be labelled
 479           -> Bool                               -- True <=> polymorphic case
 480           -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
 481           -> StgCaseDefault                     -- The default
 482           -> Bool                               -- Context switch at alts?
 483           -> FCode ([(ConTag, AbstractC)],      -- The branches
 484                     AbstractC                   -- The default case
 485              )
 486
 487 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
 488           emit_yield{-should a yield macro be emitted?-}
 489
 490   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 491              (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
 492 \end{code}
 493
 494 \begin{code}
 495 cgAlgDefault :: GCFlag
 496              -> Bool                    -- could be a function-typed result?
 497              -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
 498              -> StgCaseDefault          -- input
 499              -> Bool
 500              -> FCode AbstractC         -- output
 501
 502 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
 503   = returnFC AbsCNop
 504
 505 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
 506              (StgBindDefault rhs)
 507           emit_yield{-should a yield macro be emitted?-}
 508
 509   =     -- We have arranged that Node points to the thing
 510     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 511     getAbsC (absC restore_cc `thenC`
 512              -- HWL: maybe need yield here
 513              --(if emit_yield
 514              --   then yield [node] True
 515              --   else absC AbsCNop)                            `thenC`
 516              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 517         -- Node is live, but doesn't need to point at the thing itself;
 518         -- it's ok for Node to point to an indirection or FETCH_ME
 519         -- Hence no need to re-enter Node.
 520     )                                   `thenFC` \ abs_c ->
 521
 522     let
 523         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 524                     | otherwise         = abs_c
 525     in
 526     returnFC final_abs_c
 527   where
 528     lbl = mkDefaultLabel uniq
 529
 530 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 531
 532 cgAlgAlt :: GCFlag
 533          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 534          -> Bool                               -- Context switch at alts?
 535          -> (DataCon, [Id], [Bool], StgExpr)
 536          -> FCode (ConTag, AbstractC)
 537
 538 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 539          emit_yield{-should a yield macro be emitted?-}
 540          (con, args, use_mask, rhs)
 541   =
 542     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 543     getAbsC (absC restore_cc `thenC`
 544              -- HWL: maybe need yield here
 545              -- (if emit_yield
 546              --    then yield [node] True               -- XXX live regs wrong
 547              --    else absC AbsCNop)                               `thenC`
 548              (case gc_flag of
 549                 NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
 550                 GCMayHappen -> bindConArgs con args
 551              )  `thenC`
 552              possibleHeapCheck gc_flag False [node] [] Nothing (
 553              cgExpr rhs)
 554             ) `thenFC` \ abs_c ->
 555     let
 556         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 557                     | otherwise         = abs_c
 558     in
 559     returnFC (tag, final_abs_c)
 560   where
 561     tag = dataConTag con
 562     lbl = mkAltLabel uniq tag
 563
 564 cgUnboxedTupleAlt
 565         :: Unique                       -- unique for label of the alternative
 566         -> Maybe VirtualSpOffset        -- Restore cost centre
 567         -> Bool                         -- ctxt switch
 568         -> (DataCon, [Id], [Bool], StgExpr) -- alternative
 569         -> FCode AbstractC
 570
 571 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
 572   = getAbsC (
 573         bindUnboxedTupleComponents args
 574                       `thenFC` \ (live_regs,tags,stack_res) ->
 575
 576         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 577         absC restore_cc `thenC`
 578
 579         -- HWL: maybe need yield here
 580         -- (if emit_yield
 581         --    then yield live_regs True         -- XXX live regs wrong?
 582         --    else absC AbsCNop)                         `thenC`
 583         let
 584               -- ToDo: could maybe use Nothing here if stack_res is False
 585               -- since the heap-check can just return to the top of the
 586               -- stack.
 587               ret_addr = Just lbl
 588         in
 589
 590         -- free up stack slots containing tags,
 591         freeStackSlots (map fst tags)           `thenC`
 592
 593         -- generate a heap check if necessary
 594         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 595
 596         -- and finally the code for the alternative
 597         cgExpr rhs)
 598     )
 599 \end{code}
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 Turgid-but-non-monadic code to conjure up the required info from
 608 algebraic case alternatives for semi-tagging.
 609
 610 \begin{code}
 611 cgSemiTaggedAlts :: Id
 612                  -> [(DataCon, [Id], [Bool], StgExpr)]
 613                  -> GenStgCaseDefault Id Id
 614                  -> SemiTaggingStuff
 615
 616 cgSemiTaggedAlts binder alts deflt
 617   = Just (map st_alt alts, st_deflt deflt)
 618   where
 619     uniq        = getUnique binder
 620
 621     st_deflt StgNoDefault = Nothing
 622
 623     st_deflt (StgBindDefault _)
 624       = Just (Just binder,
 625               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 626                mkDefaultLabel uniq)
 627              )
 628
 629     st_alt (con, args, use_mask, _)
 630       =  -- Ha!  Nothing to do; Node already points to the thing
 631          (con_tag,
 632            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 633                 [mkIntCLit (length args)], -- how big the thing in the heap is
 634              join_label)
 635             )
 636       where
 637         con_tag     = dataConTag con
 638         join_label  = mkAltLabel uniq con_tag
 639 \end{code}
 640
 641 %************************************************************************
 642 %*                                                                      *
 643 \subsection[CgCase-prim-alts]{Primitive alternatives}
 644 %*                                                                      *
 645 %************************************************************************
 646
 647 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 648 for dealing with the alternatives of a primitive @case@, given an
 649 addressing mode for the thing to scrutinise.  It also keeps track of
 650 the maximum stack depth encountered down any branch.
 651
 652 As usual, no binders in the alternatives are yet bound.
 653
 654 \begin{code}
 655 cgPrimInlineAlts bndr tycon alts deflt
 656   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 657   where
 658         uniq = getUnique bndr
 659         kind = tyConPrimRep tycon
 660
 661 cgPrimEvalAlts bndr tycon alts deflt
 662   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 663   where
 664         reg  = WARN( case kind of { PtrRep -> True; other -> False },
 665                      text "cgPrimEE" <+> ppr bndr <+> ppr tycon  )
 666                dataReturnConvPrim kind
 667         kind = tyConPrimRep tycon
 668
 669 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 670   =     -- first bind the default if necessary
 671     bindNewPrimToAmode bndr scrutinee           `thenC`
 672     cgPrimAlts gc_flag scrutinee alts deflt regs
 673
 674 cgPrimAlts gc_flag scrutinee alts deflt regs
 675   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 676              (cgPrimDefault gc_flag regs deflt)
 677                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 678
 679     absC (CSwitch scrutinee alt_absCs deflt_absC)
 680         -- CSwitch does sensible things with one or zero alternatives
 681
 682
 683 cgPrimAlt :: GCFlag
 684           -> [MagicId]                  -- live registers
 685           -> (Literal, StgExpr)         -- The alternative
 686           -> FCode (Literal, AbstractC) -- Its compiled form
 687
 688 cgPrimAlt gc_flag regs (lit, rhs)
 689   = getAbsC rhs_code     `thenFC` \ absC ->
 690     returnFC (lit,absC)
 691   where
 692     rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
 693
 694 cgPrimDefault :: GCFlag
 695               -> [MagicId]              -- live registers
 696               -> StgCaseDefault
 697               -> FCode AbstractC
 698
 699 cgPrimDefault gc_flag regs StgNoDefault
 700   = panic "cgPrimDefault: No default in prim case"
 701
 702 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 703   = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
 704 \end{code}
 705
 706
 707 %************************************************************************
 708 %*                                                                      *
 709 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 710 %*                                                                      *
 711 %************************************************************************
 712
 713 \begin{code}
 714 saveVolatileVarsAndRegs
 715     :: StgLiveVars                    -- Vars which should be made safe
 716     -> FCode (AbstractC,              -- Assignments to do the saves
 717               EndOfBlockInfo,         -- sequel for the alts
 718               Maybe VirtualSpOffset)  -- Slot for current cost centre
 719
 720
 721 saveVolatileVarsAndRegs vars
 722   = saveVolatileVars vars       `thenFC` \ var_saves ->
 723     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 724     getEndOfBlockInfo           `thenFC` \ eob_info ->
 725     returnFC (mkAbstractCs [var_saves, cc_save],
 726               eob_info,
 727               maybe_cc_slot)
 728
 729
 730 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 731                  -> FCode AbstractC     -- Assignments to to the saves
 732
 733 saveVolatileVars vars
 734   = save_em (varSetElems vars)
 735   where
 736     save_em [] = returnFC AbsCNop
 737
 738     save_em (var:vars)
 739       = getCAddrModeIfVolatile var `thenFC` \ v ->
 740         case v of
 741             Nothing         -> save_em vars -- Non-volatile, so carry on
 742
 743
 744             Just vol_amode  ->  -- Aha! It's volatile
 745                                save_var var vol_amode   `thenFC` \ abs_c ->
 746                                save_em vars             `thenFC` \ abs_cs ->
 747                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 748
 749     save_var var vol_amode
 750       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 751         rebindToStack var slot          `thenC`
 752         getSpRelOffset slot             `thenFC` \ sp_rel ->
 753         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 754       where
 755         kind = getAmodeRep vol_amode
 756 \end{code}
 757
 758 ---------------------------------------------------------------------------
 759
 760 When we save the current cost centre (which is done for lexical
 761 scoping), we allocate a free stack location, and return (a)~the
 762 virtual offset of the location, to pass on to the alternatives, and
 763 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 764
 765 \begin{code}
 766 saveCurrentCostCentre ::
 767         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 768                AbstractC)               -- Assignment to save it
 769
 770 saveCurrentCostCentre
 771   = if not opt_SccProfilingOn then
 772         returnFC (Nothing, AbsCNop)
 773     else
 774         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 775         dataStackSlots [slot]                         `thenC`
 776         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 777         returnFC (Just slot,
 778                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 779
 780 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 781 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 782 restoreCurrentCostCentre (Just slot)
 783  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 784    freeStackSlots [slot]                         `thenC`
 785    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 786     -- we use the RESTORE_CCCS macro, rather than just
 787     -- assigning into CurCostCentre, in case RESTORE_CCCS
 788     -- has some sanity-checking in it.
 789 \end{code}
 790
 791 %************************************************************************
 792 %*                                                                      *
 793 \subsection[CgCase-return-vec]{Building a return vector}
 794 %*                                                                      *
 795 %************************************************************************
 796
 797 Build a return vector, and return a suitable label addressing
 798 mode for it.
 799
 800 \begin{code}
 801 mkReturnVector :: Unique
 802                -> [(ConTag, AbstractC)] -- Branch codes
 803                -> AbstractC             -- Default case
 804                -> SRT                   -- continuation's SRT
 805                -> Liveness              -- stack liveness
 806                -> CtrlReturnConvention
 807                -> FCode CAddrMode
 808
 809 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 810   = getSRTInfo srt              `thenFC` \ srt_info ->
 811     let
 812      (return_vec_amode, vtbl_body) = case ret_conv of {
 813
 814         -- might be a polymorphic case...
 815       UnvectoredReturn 0 ->
 816         ASSERT(null tagged_alt_absCs)
 817         (CLbl ret_label RetRep,
 818          absC (CRetDirect uniq deflt_absC srt_info liveness));
 819
 820       UnvectoredReturn n ->
 821         -- find the tag explicitly rather than using tag_reg for now.
 822         -- on architectures with lots of regs the tag will be loaded
 823         -- into tag_reg by the code doing the returning.
 824         let
 825           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 826         in
 827         (CLbl ret_label RetRep,
 828          absC (CRetDirect uniq
 829                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 830                             srt_info
 831                             liveness));
 832
 833       VectoredReturn table_size ->
 834         let
 835           (vector_table, alts_absC) =
 836             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 837
 838           ret_vector = CRetVector vtbl_label vector_table srt_info liveness
 839         in
 840         (CLbl vtbl_label DataPtrRep,
 841          -- alts come first, because we don't want to declare all the symbols
 842          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 843         )
 844
 845     } in
 846     vtbl_body                                               `thenC`
 847     returnFC return_vec_amode
 848     -- )
 849   where
 850
 851     vtbl_label = mkVecTblLabel uniq
 852     ret_label = mkReturnInfoLabel uniq
 853
 854     deflt_lbl =
 855         case nonemptyAbsC deflt_absC of
 856                  -- the simplifier might have eliminated a case
 857            Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
 858            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 859
 860     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 861     mk_vector_entry tag
 862       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 863              []     -> (deflt_lbl, AbsCNop)
 864              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 865              _      -> panic "mkReturnVector: too many"
 866 \end{code}
 867
 868 %************************************************************************
 869 %*                                                                      *
 870 \subsection[CgCase-utils]{Utilities for handling case expressions}
 871 %*                                                                      *
 872 %************************************************************************
 873
 874 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 875 heap check or not.  These heap checks are always in a case
 876 alternative, so we use altHeapCheck.
 877
 878 \begin{code}
 879 possibleHeapCheck
 880         :: GCFlag
 881         -> Bool                         --  True <=> algebraic case
 882         -> [MagicId]                    --  live registers
 883         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 884         -> Maybe Unique                 --  return address unique
 885         -> Code                         --  continuation
 886         -> Code
 887
 888 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
 889   = altHeapCheck is_alg regs tags AbsCNop lbl code
 890 possibleHeapCheck NoGC  _ _ tags lbl code
 891   = code
 892 \end{code}