ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 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_poly 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_poly 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_poly uniq cc_slot must_label_branch StgNoDefault _
 519   = returnFC AbsCNop
 520
 521 cgAlgDefault gc_flag is_poly 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              algAltHeapCheck gc_flag is_poly [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              algAltHeapCheck 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         primAltHeapCheck GCMayHappen 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  = dataReturnConvPrim kind
 681         kind = tyConPrimRep tycon
 682
 683 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 684   =     -- first bind the default if necessary
 685     bindNewPrimToAmode bndr scrutinee           `thenC`
 686     cgPrimAlts gc_flag scrutinee alts deflt regs
 687
 688 cgPrimAlts gc_flag scrutinee alts deflt regs
 689   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 690              (cgPrimDefault gc_flag regs deflt)
 691                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 692
 693     absC (CSwitch scrutinee alt_absCs deflt_absC)
 694         -- CSwitch does sensible things with one or zero alternatives
 695
 696
 697 cgPrimAlt :: GCFlag
 698           -> [MagicId]                  -- live registers
 699           -> (Literal, StgExpr)         -- The alternative
 700           -> FCode (Literal, AbstractC) -- Its compiled form
 701
 702 cgPrimAlt gc_flag regs (lit, rhs)
 703   = getAbsC rhs_code     `thenFC` \ absC ->
 704     returnFC (lit,absC)
 705   where
 706     rhs_code = primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs)
 707
 708 cgPrimDefault :: GCFlag
 709               -> [MagicId]              -- live registers
 710               -> StgCaseDefault
 711               -> FCode AbstractC
 712
 713 cgPrimDefault gc_flag regs StgNoDefault
 714   = panic "cgPrimDefault: No default in prim case"
 715
 716 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 717   = getAbsC (primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs))
 718 \end{code}
 719
 720
 721 %************************************************************************
 722 %*                                                                      *
 723 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 724 %*                                                                      *
 725 %************************************************************************
 726
 727 \begin{code}
 728 saveVolatileVarsAndRegs
 729     :: StgLiveVars                    -- Vars which should be made safe
 730     -> FCode (AbstractC,              -- Assignments to do the saves
 731               EndOfBlockInfo,         -- sequel for the alts
 732               Maybe VirtualSpOffset)  -- Slot for current cost centre
 733
 734
 735 saveVolatileVarsAndRegs vars
 736   = saveVolatileVars vars       `thenFC` \ var_saves ->
 737     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 738     getEndOfBlockInfo           `thenFC` \ eob_info ->
 739     returnFC (mkAbstractCs [var_saves, cc_save],
 740               eob_info,
 741               maybe_cc_slot)
 742
 743
 744 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 745                  -> FCode AbstractC     -- Assignments to to the saves
 746
 747 saveVolatileVars vars
 748   = save_em (varSetElems vars)
 749   where
 750     save_em [] = returnFC AbsCNop
 751
 752     save_em (var:vars)
 753       = getCAddrModeIfVolatile var `thenFC` \ v ->
 754         case v of
 755             Nothing         -> save_em vars -- Non-volatile, so carry on
 756
 757
 758             Just vol_amode  ->  -- Aha! It's volatile
 759                                save_var var vol_amode   `thenFC` \ abs_c ->
 760                                save_em vars             `thenFC` \ abs_cs ->
 761                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 762
 763     save_var var vol_amode
 764       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 765         rebindToStack var slot          `thenC`
 766         getSpRelOffset slot             `thenFC` \ sp_rel ->
 767         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 768       where
 769         kind = getAmodeRep vol_amode
 770 \end{code}
 771
 772 ---------------------------------------------------------------------------
 773
 774 When we save the current cost centre (which is done for lexical
 775 scoping), we allocate a free stack location, and return (a)~the
 776 virtual offset of the location, to pass on to the alternatives, and
 777 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 778
 779 \begin{code}
 780 saveCurrentCostCentre ::
 781         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 782                AbstractC)               -- Assignment to save it
 783
 784 saveCurrentCostCentre
 785   = if not opt_SccProfilingOn then
 786         returnFC (Nothing, AbsCNop)
 787     else
 788         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 789         dataStackSlots [slot]                         `thenC`
 790         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 791         returnFC (Just slot,
 792                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 793
 794 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 795 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 796 restoreCurrentCostCentre (Just slot)
 797  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 798    freeStackSlots [slot]                         `thenC`
 799    returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 800     -- we use the RESTORE_CCCS macro, rather than just
 801     -- assigning into CurCostCentre, in case RESTORE_CCCS
 802     -- has some sanity-checking in it.
 803 \end{code}
 804
 805 %************************************************************************
 806 %*                                                                      *
 807 \subsection[CgCase-return-vec]{Building a return vector}
 808 %*                                                                      *
 809 %************************************************************************
 810
 811 Build a return vector, and return a suitable label addressing
 812 mode for it.
 813
 814 \begin{code}
 815 mkReturnVector :: Unique
 816                -> [(ConTag, AbstractC)] -- Branch codes
 817                -> AbstractC             -- Default case
 818                -> SRT                   -- continuation's SRT
 819                -> Liveness              -- stack liveness
 820                -> CtrlReturnConvention
 821                -> FCode CAddrMode
 822
 823 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 824   = getSRTInfo srt              `thenFC` \ srt_info ->
 825     let
 826      (return_vec_amode, vtbl_body) = case ret_conv of {
 827
 828         -- might be a polymorphic case...
 829       UnvectoredReturn 0 ->
 830         ASSERT(null tagged_alt_absCs)
 831         (CLbl ret_label RetRep,
 832          absC (CRetDirect uniq deflt_absC srt_info liveness));
 833
 834       UnvectoredReturn n ->
 835         -- find the tag explicitly rather than using tag_reg for now.
 836         -- on architectures with lots of regs the tag will be loaded
 837         -- into tag_reg by the code doing the returning.
 838         let
 839           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 840         in
 841         (CLbl ret_label RetRep,
 842          absC (CRetDirect uniq
 843                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 844                             srt_info
 845                             liveness));
 846
 847       VectoredReturn table_size ->
 848         let
 849           (vector_table, alts_absC) =
 850             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 851
 852           ret_vector = CRetVector vtbl_label vector_table srt_info liveness
 853         in
 854         (CLbl vtbl_label DataPtrRep,
 855          -- alts come first, because we don't want to declare all the symbols
 856          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 857         )
 858
 859     } in
 860     vtbl_body                                               `thenC`
 861     returnFC return_vec_amode
 862     -- )
 863   where
 864
 865     vtbl_label = mkVecTblLabel uniq
 866     ret_label = mkReturnInfoLabel uniq
 867
 868     deflt_lbl =
 869         case nonemptyAbsC deflt_absC of
 870                  -- the simplifier might have eliminated a case
 871            Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
 872            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 873
 874     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 875     mk_vector_entry tag
 876       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 877              []     -> (deflt_lbl, AbsCNop)
 878              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 879              _      -> panic "mkReturnVector: too many"
 880 \end{code}
 881
 882 %************************************************************************
 883 %*                                                                      *
 884 \subsection[CgCase-utils]{Utilities for handling case expressions}
 885 %*                                                                      *
 886 %************************************************************************
 887
 888 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 889 heap check or not.  These heap checks are always in a case
 890 alternative, so we use altHeapCheck.
 891
 892 \begin{code}
 893 algAltHeapCheck
 894         :: GCFlag
 895         -> Bool                         --  True <=> polymorphic case
 896         -> [MagicId]                    --  live registers
 897         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 898         -> Maybe Unique                 --  return address unique
 899         -> Code                         --  continuation
 900         -> Code
 901
 902 algAltHeapCheck GCMayHappen is_poly regs tags lbl code
 903   = altHeapCheck is_poly False regs tags AbsCNop lbl code
 904 algAltHeapCheck NoGC    _ _ tags lbl code
 905   = code
 906
 907 primAltHeapCheck GCMayHappen regs tags lbl code
 908   = altHeapCheck False True regs tags AbsCNop lbl code
 909 primAltHeapCheck NoGC _ _ _ code
 910   = code
 911 \end{code}