ghc/compiler/codeGen/CgCase.lhs

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