ghc/compiler/codeGen/CgCase.lhs

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