ghc/compiler/codeGen/CgCase.lhs

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