ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %********************************************************
   5 %*                                                      *
   6 \section[CgCase]{Converting @StgCase@ expressions}
   7 %*                                                      *
   8 %********************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
  14
  15 IMP_Ubiq(){-uitous-}
  16 IMPORT_DELOOPER(CgLoop2)                ( cgExpr, getPrimOpArgAmodes )
  17
  18 import CgMonad
  19 import StgSyn
  20 import AbsCSyn
  21
  22 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
  23                           magicIdPrimRep, getAmodeRep
  24                         )
  25 import CgBindery        ( getVolatileRegs, getArgAmode, getArgAmodes,
  26                           bindNewToReg, bindNewToTemp,
  27                           bindNewPrimToAmode,
  28                           rebindToAStack, rebindToBStack,
  29                           getCAddrModeAndInfo, getCAddrModeIfVolatile,
  30                           idInfoToAmode
  31                         )
  32 import CgCon            ( buildDynCon, bindConArgs )
  33 import CgHeapery        ( heapCheck, yield )
  34 import CgRetConv        ( dataReturnConvAlg, dataReturnConvPrim,
  35                           ctrlReturnConvAlg,
  36                           DataReturnConvention(..), CtrlReturnConvention(..),
  37                           assignPrimOpResultRegs,
  38                           makePrimOpArgsRobust
  39                         )
  40 import CgStackery       ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
  41 import CgTailCall       ( tailCallBusiness, performReturn )
  42 import CgUsages         ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
  43 import CLabel           ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
  44                           mkAltLabel
  45                         )
  46 import ClosureInfo      ( mkConLFInfo, mkLFArgument, layOutDynCon )
  47 import CmdLineOpts      ( opt_SccProfilingOn, opt_GranMacros )
  48 import CostCentre       ( useCurrentCostCentre, CostCentre )
  49 import HeapOffs         ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
  50 import Id               ( idPrimRep, toplevelishId,
  51                           dataConTag, fIRST_TAG, SYN_IE(ConTag),
  52                           isDataCon, SYN_IE(DataCon),
  53                           idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id)
  54                         )
  55 import Literal          ( Literal )
  56 import Maybes           ( catMaybes )
  57 import Outputable       ( Outputable(..), PprStyle(..) )
  58 import PprType          ( GenType{-instance Outputable-} )
  59 import Pretty           ( Doc )
  60 import PrimOp           ( primOpCanTriggerGC, PrimOp(..),
  61                           primOpStackRequired, StackRequirement(..)
  62                         )
  63 import PrimRep          ( getPrimRepSize, isFollowableRep, retPrimRepSize,
  64                           PrimRep(..)
  65                         )
  66 import TyCon            ( isEnumerationTyCon )
  67 import Type             ( typePrimRep,
  68                           getAppSpecDataTyConExpandingDicts,
  69                           maybeAppSpecDataTyConExpandingDicts,
  70                           SYN_IE(Type)
  71                         )
  72 import Unique           ( Unique )
  73 import UniqFM           ( Uniquable(..) )
  74 import Util             ( sortLt, isIn, isn'tIn, zipEqual,
  75                           pprError, panic, assertPanic
  76                         )
  77
  78 \end{code}
  79
  80 \begin{code}
  81 data GCFlag
  82   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  83                 -- tidy before the code for the scrutinee.
  84
  85   | NoGC        -- The scrutinee is a primitive value, or a call to a
  86                 -- primitive op which does no GC.  Hence the case can
  87                 -- be done inline, without tidying up first.
  88 \end{code}
  89
  90 It is quite interesting to decide whether to put a heap-check
  91 at the start of each alternative.  Of course we certainly have
  92 to do so if the case forces an evaluation, or if there is a primitive
  93 op which can trigger GC.
  94
  95 A more interesting situation is this:
  96
  97 \begin{verbatim}
  98         !A!;
  99         ...A...
 100         case x# of
 101           0#      -> !B!; ...B...
 102           default -> !C!; ...C...
 103 \end{verbatim}
 104
 105 where \tr{!x!} indicates a possible heap-check point. The heap checks
 106 in the alternatives {\em can} be omitted, in which case the topmost
 107 heapcheck will take their worst case into account.
 108
 109 In favour of omitting \tr{!B!}, \tr{!C!}:
 110
 111 \begin{itemize}
 112 \item
 113 {\em May} save a heap overflow test,
 114         if ...A... allocates anything.  The other advantage
 115         of this is that we can use relative addressing
 116         from a single Hp to get at all the closures so allocated.
 117 \item
 118  No need to save volatile vars etc across the case
 119 \end{itemize}
 120
 121 Against:
 122
 123 \begin{itemize}
 124 \item
 125    May do more allocation than reqd.  This sometimes bites us
 126         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 127         worst-casing is done, because many many calls to nfib are leaf calls
 128         which don't need to allocate anything.
 129
 130         This never hurts us if there is only one alternative.
 131 \end{itemize}
 132
 133
 134 *** NOT YET DONE ***  The difficulty is that \tr{!B!}, \tr{!C!} need
 135 to take account of what is live, and that includes all live volatile
 136 variables, even if they also have stable analogues.  Furthermore, the
 137 stack pointers must be lined up properly so that GC sees tidy stacks.
 138 If these things are done, then the heap checks can be done at \tr{!B!} and
 139 \tr{!C!} without a full save-volatile-vars sequence.
 140
 141 \begin{code}
 142 cgCase  :: StgExpr
 143         -> StgLiveVars
 144         -> StgLiveVars
 145         -> Unique
 146         -> StgCaseAlts
 147         -> Code
 148 \end{code}
 149
 150 Several special cases for primitive operations.
 151
 152 ******* TO DO TO DO: fix what follows
 153
 154 Special case for
 155
 156         case (op x1 ... xn) of
 157           y -> e
 158
 159 where the type of the case scrutinee is a multi-constuctor algebraic type.
 160 Then we simply compile code for
 161
 162         let y = op x1 ... xn
 163         in
 164         e
 165
 166 In this case:
 167
 168         case (op x1 ... xn) of
 169            C a b -> ...
 170            y     -> e
 171
 172 where the type of the case scrutinee is a multi-constuctor algebraic type.
 173 we just bomb out at the moment. It never happens in practice.
 174
 175 **** END OF TO DO TO DO
 176
 177 \begin{code}
 178 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
 179        (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
 180   = if not (null alts) then
 181         panic "cgCase: case on PrimOp with default *and* alts\n"
 182         -- For now, die if alts are non-empty
 183     else
 184         cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
 185   where
 186     scrut_rhs       = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
 187                                 Updatable [] scrut
 188     scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
 189                         -- Hack, hack
 190 \end{code}
 191
 192
 193 \begin{code}
 194 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
 195   | not (primOpCanTriggerGC op)
 196   =
 197         -- Get amodes for the arguments and results
 198     getPrimOpArgAmodes op args                  `thenFC` \ arg_amodes ->
 199     let
 200         result_amodes = getPrimAppResultAmodes uniq alts
 201         liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
 202     in
 203         -- Perform the operation
 204     getVolatileRegs live_in_alts                        `thenFC` \ vol_regs ->
 205
 206     -- seq cannot happen here => no additional B Stack alloc
 207
 208     absC (COpStmt result_amodes op
 209                  arg_amodes -- note: no liveness arg
 210                  liveness_mask vol_regs)                `thenC`
 211
 212         -- Scrutinise the result
 213     cgInlineAlts NoGC uniq alts
 214
 215   | otherwise   -- *Can* trigger GC
 216   = getPrimOpArgAmodes op args  `thenFC` \ arg_amodes ->
 217
 218         -- Get amodes for the arguments and results, and assign to regs
 219         -- (Can-trigger-gc primops guarantee to have their (nonRobust)
 220         --  args in regs)
 221     let
 222         op_result_regs = assignPrimOpResultRegs op
 223
 224         op_result_amodes = map CReg op_result_regs
 225
 226         (op_arg_amodes, liveness_mask, arg_assts)
 227           = makePrimOpArgsRobust op arg_amodes
 228
 229         liveness_arg  = mkIntCLit liveness_mask
 230     in
 231         -- Tidy up in case GC happens...
 232
 233         -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
 234         -- Reason: the arg_assts computed above may refer to some stack slots
 235         -- which are not live in the alts.  So we mustn't use those slots
 236         -- to save volatile vars in!
 237     nukeDeadBindings live_in_whole_case `thenC`
 238     saveVolatileVars live_in_alts       `thenFC` \ volatile_var_save_assts ->
 239
 240     -- Allocate stack words for the prim-op itself,
 241     -- these are guaranteed to be ON TOP OF the stack.
 242     -- Currently this is used *only* by the seq# primitive op.
 243     let
 244       (a_req,b_req) = case (primOpStackRequired op) of
 245                            NoStackRequired        -> (0, 0)
 246                            FixedStackRequired a b -> (a, b)
 247                            VariableStackRequired  -> (0, 0) -- i.e. don't care
 248     in
 249     allocAStackTop a_req                `thenFC` \ a_slot ->
 250     allocBStackTop b_req                `thenFC` \ b_slot ->
 251
 252     getEndOfBlockInfo                   `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
 253     -- a_req and b_req allocate stack space that is taken care of by the
 254     -- macros generated for the primops; thus, we there is no need to adjust
 255     -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
 256     -- currently all this is only used for SeqOp
 257     forkEval (if True {- a_req==0 && b_req==0 -}
 258                 then eob_info
 259                 else (EndOfBlockInfo (args_spa+a_req)
 260                                      (args_spb+b_req) sequel)) nopC
 261              (
 262               getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
 263               absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
 264                                         `thenC`
 265               returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
 266                                  Nothing{-no semi-tagging-}))
 267             `thenFC` \ new_eob_info ->
 268
 269         -- Record the continuation info
 270     setEndOfBlockInfo new_eob_info (
 271
 272         -- Now "return" to the inline alternatives; this will get
 273         -- compiled to a fall-through.
 274     let
 275         simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
 276
 277         -- do_op_and_continue will be passed an amode for the continuation
 278         do_op_and_continue sequel
 279           = absC (COpStmt op_result_amodes
 280                           op
 281                           (pin_liveness op liveness_arg op_arg_amodes)
 282                           liveness_mask
 283                           [{-no vol_regs-}])
 284                                         `thenC`
 285
 286             sequelToAmode sequel        `thenFC` \ dest_amode ->
 287             absC (CReturn dest_amode DirectReturn)
 288
 289                 -- Note: we CJump even for algebraic data types,
 290                 -- because cgInlineAlts always generates code, never a
 291                 -- vector.
 292     in
 293     performReturn simultaneous_assts do_op_and_continue live_in_alts
 294     )
 295   where
 296     -- for all PrimOps except ccalls, we pin the liveness info
 297     -- on as the first "argument"
 298     -- ToDo: un-duplicate?
 299
 300     pin_liveness (CCallOp _ _ _ _ _) _ args = args
 301     pin_liveness other_op liveness_arg args
 302       = liveness_arg :args
 303
 304     vtbl_label = mkVecTblLabel uniq
 305     return_label = mkReturnPtLabel uniq
 306
 307 \end{code}
 308
 309 Another special case: scrutinising a primitive-typed variable.  No
 310 evaluation required.  We don't save volatile variables, nor do we do a
 311 heap-check in the alternatives.  Instead, the heap usage of the
 312 alternatives is worst-cased and passed upstream.  This can result in
 313 allocating more heap than strictly necessary, but it will sometimes
 314 eliminate a heap check altogether.
 315
 316 \begin{code}
 317 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
 318   = getArgAmode v               `thenFC` \ amode ->
 319     cgPrimAltsGivenScrutinee NoGC amode alts deflt
 320 \end{code}
 321
 322 Special case: scrutinising a non-primitive variable.
 323 This can be done a little better than the general case, because
 324 we can reuse/trim the stack slot holding the variable (if it is in one).
 325
 326 \begin{code}
 327 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
 328         live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
 329   =
 330     getCAddrModeAndInfo fun             `thenFC` \ (fun_amode, lf_info) ->
 331     getArgAmodes args                   `thenFC` \ arg_amodes ->
 332
 333         -- Squish the environment
 334     nukeDeadBindings live_in_alts       `thenC`
 335     saveVolatileVarsAndRegs live_in_alts
 336                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 337
 338     forkEval alts_eob_info
 339              nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
 340     setEndOfBlockInfo scrut_eob_info  (
 341       tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
 342     )
 343
 344 \end{code}
 345
 346 Finally, here is the general case.
 347
 348 \begin{code}
 349 cgCase expr live_in_whole_case live_in_alts uniq alts
 350   =     -- Figure out what volatile variables to save
 351     nukeDeadBindings live_in_whole_case `thenC`
 352     saveVolatileVarsAndRegs live_in_alts
 353                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 354
 355         -- Save those variables right now!
 356     absC save_assts                     `thenC`
 357
 358     forkEval alts_eob_info
 359         (nukeDeadBindings live_in_alts)
 360         (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
 361
 362     setEndOfBlockInfo scrut_eob_info (cgExpr expr)
 363 \end{code}
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection[CgCase-primops]{Primitive applications}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 Get result amodes for a primitive operation, in the case wher GC can't happen.
 372 The  amodes are returned in canonical order, ready for the prim-op!
 373
 374         Alg case: temporaries named as in the alternatives,
 375                   plus (CTemp u) for the tag (if needed)
 376         Prim case: (CTemp u)
 377
 378 This is all disgusting, because these amodes must be consistent with those
 379 invented by CgAlgAlts.
 380
 381 \begin{code}
 382 getPrimAppResultAmodes
 383         :: Unique
 384         -> StgCaseAlts
 385         -> [CAddrMode]
 386 \end{code}
 387
 388 \begin{code}
 389 -- If there's an StgBindDefault which does use the bound
 390 -- variable, then we can only handle it if the type involved is
 391 -- an enumeration type.   That's important in the case
 392 -- of comparisions:
 393 --
 394 --      case x ># y of
 395 --        r -> f r
 396 --
 397 -- The only reason for the restriction to *enumeration* types is our
 398 -- inability to invent suitable temporaries to hold the results;
 399 -- Elaborating the CTemp addr mode to have a second uniq field
 400 -- (which would simply count from 1) would solve the problem.
 401 -- Anyway, cgInlineAlts is now capable of handling all cases;
 402 -- it's only this function which is being wimpish.
 403
 404 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
 405   | isEnumerationTyCon spec_tycon = [tag_amode]
 406   | otherwise                     = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
 407   where
 408     -- A temporary variable to hold the tag; this is unaffected by GC because
 409     -- the heap-checks in the branches occur after the switch
 410     tag_amode     = CTemp uniq IntRep
 411     (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
 412
 413 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
 414         -- Default is either StgNoDefault or StgBindDefault with unused binder
 415   = case alts of
 416         [_]     -> arg_amodes                   -- No need for a tag
 417         other   -> tag_amode : arg_amodes
 418   where
 419     -- A temporary variable to hold the tag; this is unaffected by GC because
 420     -- the heap-checks in the branches occur after the switch
 421     tag_amode = CTemp uniq IntRep
 422
 423     -- Sort alternatives into canonical order; there must be a complete
 424     -- set because there's no default case.
 425     sorted_alts = sortLt lt alts
 426     (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
 427
 428     arg_amodes :: [CAddrMode]
 429
 430     -- Turn them into amodes
 431     arg_amodes = concat (map mk_amodes sorted_alts)
 432     mk_amodes (con, args, use_mask, rhs)
 433       = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
 434 \end{code}
 435
 436 The situation is simpler for primitive
 437 results, because there is only one!
 438
 439 \begin{code}
 440 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
 441   = [CTemp uniq (typePrimRep ty)]
 442 \end{code}
 443
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection[CgCase-alts]{Alternatives}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 @cgEvalAlts@ returns an addressing mode for a continuation for the
 452 alternatives of a @case@, used in a context when there
 453 is some evaluation to be done.
 454
 455 \begin{code}
 456 cgEvalAlts :: Maybe VirtualSpBOffset    -- Offset of cost-centre to be restored, if any
 457            -> Unique
 458            -> StgCaseAlts
 459            -> FCode Sequel              -- Any addr modes inside are guaranteed to be a label
 460                                         -- so that we can duplicate it without risk of
 461                                         -- duplicating code
 462
 463 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
 464   =     -- Generate the instruction to restore cost centre, if any
 465     restoreCurrentCostCentre cc_slot    `thenFC` \ cc_restore ->
 466
 467         -- Generate sequel info for use downstream
 468         -- At the moment, we only do it if the type is vector-returnable.
 469         -- Reason: if not, then it costs extra to label the
 470         -- alternatives, because we'd get return code like:
 471         --
 472         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 473         --
 474         -- which is worse than having the alt code in the switch statement
 475
 476     let
 477         (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
 478
 479         use_labelled_alts
 480           = case ctrlReturnConvAlg spec_tycon of
 481               VectoredReturn _ -> True
 482               _                -> False
 483
 484         semi_tagged_stuff
 485           = if not use_labelled_alts then
 486                 Nothing -- no semi-tagging info
 487             else
 488                 cgSemiTaggedAlts uniq alts deflt -- Just <something>
 489     in
 490     cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
 491                                         `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 492
 493     mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
 494
 495     returnFC (CaseAlts return_vec semi_tagged_stuff)
 496
 497 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
 498   =     -- Generate the instruction to restore cost centre, if any
 499     restoreCurrentCostCentre cc_slot                     `thenFC` \ cc_restore ->
 500
 501         -- Generate the switch
 502     getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt)  `thenFC` \ abs_c ->
 503
 504         -- Generate the labelled block, starting with restore-cost-centre
 505     absC (CRetUnVector vtbl_label
 506          (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
 507                                                          `thenC`
 508         -- Return an amode for the block
 509     returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
 510   where
 511     vtbl_label = mkVecTblLabel uniq
 512     return_label = mkReturnPtLabel uniq
 513 \end{code}
 514
 515
 516 \begin{code}
 517 cgInlineAlts :: GCFlag -> Unique
 518              -> StgCaseAlts
 519              -> Code
 520 \end{code}
 521
 522 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 523 we  do  an inlining of the  case  no separate  functions  for returning are
 524 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 525 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 526 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 527
 528 First case: algebraic case, exactly one alternative, no default.
 529 In this case the primitive op will not have set a temporary to the
 530 tag, so we shouldn't generate a switch statment.  Instead we just
 531 do the right thing.
 532
 533 \begin{code}
 534 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
 535   = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
 536 \end{code}
 537
 538 Second case: algebraic case, several alternatives.
 539 Tag is held in a temporary.
 540
 541 \begin{code}
 542 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
 543   = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
 544                 ty alts deflt
 545                 False{-don't emit yield-}  `thenFC` \ (tagged_alts, deflt_c) ->
 546
 547         -- Do the switch
 548     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 549  where
 550     -- A temporary variable to hold the tag; this is unaffected by GC because
 551     -- the heap-checks in the branches occur after the switch
 552     tag_amode = CTemp uniq IntRep
 553 \end{code}
 554
 555 Third (real) case: primitive result type.
 556
 557 \begin{code}
 558 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
 559   = cgPrimAlts gc_flag uniq ty alts deflt
 560 \end{code}
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 In @cgAlgAlts@, none of the binders in the alternatives are
 570 assumed to be yet bound.
 571
 572 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 573 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 574 beginning of  each alternative. Normally we  want that. The  only exception
 575 are inlined alternatives.
 576
 577 \begin{code}
 578 cgAlgAlts :: GCFlag
 579           -> Unique
 580           -> AbstractC                          -- Restore-cost-centre instruction
 581           -> Bool                               -- True <=> branches must be labelled
 582           -> Type                               -- From the case statement
 583           -> [(Id, [Id], [Bool], StgExpr)]      -- The alternatives
 584           -> StgCaseDefault             -- The default
 585           -> Bool                               -- Context switch at alts?
 586           -> FCode ([(ConTag, AbstractC)],      -- The branches
 587                     AbstractC                   -- The default case
 588              )
 589 \end{code}
 590
 591 The case with a default which has a binder is different.  We need to
 592 pick all the constructors which aren't handled explicitly by an
 593 alternative, and which return their results in registers, allocate
 594 them explicitly in the heap, and jump to a join point for the default
 595 case.
 596
 597 OLD:  All of this only works if a heap-check is required anyway, because
 598 otherwise it isn't safe to allocate.
 599
 600 NEW (July 94): now false!  It should work regardless of gc_flag,
 601 because of the extra_branches argument now added to forkAlts.
 602
 603 We put a heap-check at the join point, for the benefit of constructors
 604 which don't need to do allocation. This means that ones which do need
 605 to allocate may end up doing two heap-checks; but that's just too bad.
 606 (We'd need two join labels otherwise.  ToDo.)
 607
 608 It's all pretty turgid anyway.
 609
 610 \begin{code}
 611 cgAlgAlts gc_flag uniq restore_cc semi_tagging
 612         ty alts deflt@(StgBindDefault binder True{-used-} _)
 613         emit_yield{-should a yield macro be emitted?-}
 614   = let
 615         extra_branches :: [FCode (ConTag, AbstractC)]
 616         extra_branches = catMaybes (map mk_extra_branch default_cons)
 617
 618         must_label_default = semi_tagging || not (null extra_branches)
 619     in
 620     forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
 621              extra_branches
 622              (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt emit_yield)
 623   where
 624
 625     default_join_lbl = mkDefaultLabel uniq
 626     jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
 627
 628     (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
 629
 630     alt_cons = [ con | (con,_,_,_) <- alts ]
 631
 632     default_cons  = [ spec_con | spec_con <- spec_cons, -- In this type
 633                                  spec_con `not_elem` alt_cons ] -- Not handled explicitly
 634         where
 635           not_elem = isn'tIn "cgAlgAlts"
 636
 637     -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
 638     -- The "maybe" is because con may return in heap, in which case there is
 639     -- nothing to do. Otherwise, we have a special case for a nullary constructor,
 640     -- but in the general case we do an allocation and heap-check.
 641
 642     mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
 643
 644     mk_extra_branch con
 645       = ASSERT(isDataCon con)
 646         case dataReturnConvAlg con of
 647           ReturnInHeap    -> Nothing
 648           ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
 649                                    returnFC (tag, abs_c)
 650                                   )
 651       where
 652         lf_info         = mkConLFInfo con
 653         tag             = dataConTag con
 654
 655         -- alloc_code generates code to allocate constructor con, whose args are
 656         -- in the arguments to alloc_code, assigning the result to Node.
 657         alloc_code :: [MagicId] -> Code
 658
 659         alloc_code regs
 660           = possibleHeapCheck gc_flag regs False (
 661                 buildDynCon binder useCurrentCostCentre con
 662                                 (map CReg regs) (all zero_size regs)
 663                                                 `thenFC` \ idinfo ->
 664                 idInfoToAmode PtrRep idinfo     `thenFC` \ amode ->
 665
 666                 absC (CAssign (CReg node) amode) `thenC`
 667                 absC jump_instruction
 668             )
 669           where
 670             zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
 671 \end{code}
 672
 673 Now comes the general case
 674
 675 \begin{code}
 676 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
 677         {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
 678           emit_yield{-should a yield macro be emitted?-}
 679
 680   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 681              [{- No "extra branches" -}]
 682              (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
 683 \end{code}
 684
 685 \begin{code}
 686 cgAlgDefault :: GCFlag
 687              -> Unique -> AbstractC -> Bool -- turgid state...
 688              -> StgCaseDefault      -- input
 689              -> Bool
 690              -> FCode AbstractC     -- output
 691
 692 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 693              StgNoDefault _
 694   = returnFC AbsCNop
 695
 696 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 697              (StgBindDefault _ False{-binder not used-} rhs)
 698              emit_yield{-should a yield macro be emitted?-}
 699
 700   = getAbsC (absC restore_cc `thenC`
 701              let
 702                 emit_gran_macros = opt_GranMacros
 703              in
 704              (if emit_gran_macros && emit_yield
 705                 then yield [] False
 706                 else absC AbsCNop)                            `thenC`
 707     -- liveness same as in possibleHeapCheck below
 708              possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
 709     let
 710         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 711                     | otherwise         = abs_c
 712     in
 713     returnFC final_abs_c
 714   where
 715     lbl = mkDefaultLabel uniq
 716
 717
 718 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 719              (StgBindDefault binder True{-binder used-} rhs)
 720           emit_yield{-should a yield macro be emitted?-}
 721
 722   =     -- We have arranged that Node points to the thing, even
 723         -- even if we return in registers
 724     bindNewToReg binder node mkLFArgument `thenC`
 725     getAbsC (absC restore_cc `thenC`
 726              let
 727                 emit_gran_macros = opt_GranMacros
 728              in
 729              (if emit_gran_macros && emit_yield
 730                 then yield [node] False
 731                 else absC AbsCNop)                            `thenC`
 732                 -- liveness same as in possibleHeapCheck below
 733              possibleHeapCheck gc_flag [node] False (cgExpr rhs)
 734         -- Node is live, but doesn't need to point at the thing itself;
 735         -- it's ok for Node to point to an indirection or FETCH_ME
 736         -- Hence no need to re-enter Node.
 737     )                                   `thenFC` \ abs_c ->
 738
 739     let
 740         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 741                     | otherwise         = abs_c
 742     in
 743     returnFC final_abs_c
 744   where
 745     lbl = mkDefaultLabel uniq
 746
 747 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 748
 749 cgAlgAlt :: GCFlag
 750          -> Unique -> AbstractC -> Bool         -- turgid state
 751          -> Bool                               -- Context switch at alts?
 752          -> (Id, [Id], [Bool], StgExpr)
 753          -> FCode (ConTag, AbstractC)
 754
 755 cgAlgAlt gc_flag uniq restore_cc must_label_branch
 756          emit_yield{-should a yield macro be emitted?-}
 757          (con, args, use_mask, rhs)
 758   = getAbsC (absC restore_cc `thenC`
 759              cgAlgAltRhs gc_flag con args use_mask rhs
 760              emit_yield
 761             ) `thenFC` \ abs_c ->
 762     let
 763         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 764                     | otherwise         = abs_c
 765     in
 766     returnFC (tag, final_abs_c)
 767   where
 768     tag = dataConTag con
 769     lbl = mkAltLabel uniq tag
 770
 771 cgAlgAltRhs :: GCFlag
 772             -> Id
 773             -> [Id]
 774             -> [Bool]
 775             -> StgExpr
 776             -> Bool              -- context switch?
 777             -> Code
 778 cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
 779   = let
 780       (live_regs, node_reqd)
 781         = case (dataReturnConvAlg con) of
 782             ReturnInHeap      -> ([],                                             True)
 783             ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
 784                                 -- Pick the live registers using the use_mask
 785                                 -- Doing so is IMPORTANT, because with semi-tagging
 786                                 -- enabled only the live registers will have valid
 787                                 -- pointers in them.
 788     in
 789      let
 790         emit_gran_macros = opt_GranMacros
 791      in
 792     (if emit_gran_macros && emit_yield
 793       then yield live_regs node_reqd
 794       else absC AbsCNop)                                    `thenC`
 795     -- liveness same as in possibleHeapCheck below
 796     possibleHeapCheck gc_flag live_regs node_reqd (
 797     (case gc_flag of
 798         NoGC        -> mapFCs bindNewToTemp args `thenFC` \ _ ->
 799                        nopC
 800         GCMayHappen -> bindConArgs con args
 801     )   `thenC`
 802     cgExpr rhs
 803     )
 804 \end{code}
 805
 806 %************************************************************************
 807 %*                                                                      *
 808 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 809 %*                                                                      *
 810 %************************************************************************
 811
 812 Turgid-but-non-monadic code to conjure up the required info from
 813 algebraic case alternatives for semi-tagging.
 814
 815 \begin{code}
 816 cgSemiTaggedAlts :: Unique
 817                  -> [(Id, [Id], [Bool], StgExpr)]
 818                  -> GenStgCaseDefault Id Id
 819                  -> SemiTaggingStuff
 820
 821 cgSemiTaggedAlts uniq alts deflt
 822   = Just (map st_alt alts, st_deflt deflt)
 823   where
 824     st_deflt StgNoDefault = Nothing
 825
 826     st_deflt (StgBindDefault binder binder_used _)
 827       = Just (if binder_used then Just binder else Nothing,
 828               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 829                mkDefaultLabel uniq)
 830              )
 831
 832     st_alt (con, args, use_mask, _)
 833       = case (dataReturnConvAlg con) of
 834
 835           ReturnInHeap ->
 836             -- Ha!  Nothing to do; Node already points to the thing
 837             (con_tag,
 838              (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 839                         [mkIntCLit (length args)], -- how big the thing in the heap is
 840              join_label)
 841             )
 842
 843           ReturnInRegs regs ->
 844             -- We have to load the live registers from the constructor
 845             -- pointed to by Node.
 846             let
 847                 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
 848
 849                 used_regs = selectByMask use_mask regs
 850
 851                 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
 852                                              reg `is_elem` used_regs]
 853
 854                 is_elem = isIn "cgSemiTaggedAlts"
 855             in
 856             (con_tag,
 857              (mkAbstractCs [
 858                 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS")  -- ToDo: macroise?
 859                         [mkIntCLit (length regs_w_offsets),
 860                          mkIntCLit (length used_regs_w_offsets)],
 861                 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
 862               join_label))
 863       where
 864         con_tag     = dataConTag con
 865         join_label  = mkAltLabel uniq con_tag
 866
 867     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
 868     move_to_reg (reg, offset)
 869       = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
 870 \end{code}
 871
 872 %************************************************************************
 873 %*                                                                      *
 874 \subsection[CgCase-prim-alts]{Primitive alternatives}
 875 %*                                                                      *
 876 %************************************************************************
 877
 878 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
 879 alternatives of a primitive @case@, given an addressing mode for the
 880 thing to scrutinise.  It also keeps track of the maximum stack depth
 881 encountered down any branch.
 882
 883 As usual, no binders in the alternatives are yet bound.
 884
 885 \begin{code}
 886 cgPrimAlts :: GCFlag
 887            -> Unique
 888            -> Type
 889            -> [(Literal, StgExpr)]      -- Alternatives
 890            -> StgCaseDefault            -- Default
 891            -> Code
 892
 893 cgPrimAlts gc_flag uniq ty alts deflt
 894   = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
 895  where
 896     -- A temporary variable, or standard register, to hold the result
 897     scrutinee = case gc_flag of
 898                      NoGC        -> CTemp uniq kind
 899                      GCMayHappen -> CReg (dataReturnConvPrim kind)
 900
 901     kind = typePrimRep ty
 902
 903
 904 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
 905   = forkAlts (map (cgPrimAlt gc_flag) alts)
 906              [{- No "extra branches" -}]
 907              (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
 908     absC (CSwitch scrutinee alt_absCs deflt_absC)
 909           -- CSwitch does sensible things with one or zero alternatives
 910
 911
 912 cgPrimAlt :: GCFlag
 913           -> (Literal, StgExpr)    -- The alternative
 914           -> FCode (Literal, AbstractC) -- Its compiled form
 915
 916 cgPrimAlt gc_flag (lit, rhs)
 917   = getAbsC rhs_code     `thenFC` \ absC ->
 918     returnFC (lit,absC)
 919   where
 920     rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
 921
 922 cgPrimDefault :: GCFlag
 923               -> CAddrMode              -- Scrutinee
 924               -> StgCaseDefault
 925               -> FCode AbstractC
 926
 927 cgPrimDefault gc_flag scrutinee StgNoDefault
 928   = panic "cgPrimDefault: No default in prim case"
 929
 930 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
 931   = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
 932
 933 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
 934   = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
 935   where
 936     regs = if isFollowableRep (getAmodeRep scrutinee) then
 937               [node] else []
 938
 939     rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
 940                cgExpr rhs
 941 \end{code}
 942
 943
 944 %************************************************************************
 945 %*                                                                      *
 946 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 947 %*                                                                      *
 948 %************************************************************************
 949
 950 \begin{code}
 951 saveVolatileVarsAndRegs
 952     :: StgLiveVars               -- Vars which should be made safe
 953     -> FCode (AbstractC,              -- Assignments to do the saves
 954        EndOfBlockInfo,                -- New sequel, recording where the return
 955                                       -- address now is
 956        Maybe VirtualSpBOffset)        -- Slot for current cost centre
 957
 958
 959 saveVolatileVarsAndRegs vars
 960   = saveVolatileVars vars     `thenFC` \ var_saves ->
 961     saveCurrentCostCentre     `thenFC` \ (maybe_cc_slot, cc_save) ->
 962     saveReturnAddress         `thenFC` \ (new_eob_info, ret_save) ->
 963     returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
 964               new_eob_info,
 965               maybe_cc_slot)
 966
 967
 968 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 969                  -> FCode AbstractC     -- Assignments to to the saves
 970
 971 saveVolatileVars vars
 972   = save_em (idSetToList vars)
 973   where
 974     save_em [] = returnFC AbsCNop
 975
 976     save_em (var:vars)
 977       = getCAddrModeIfVolatile var `thenFC` \ v ->
 978         case v of
 979             Nothing         -> save_em vars -- Non-volatile, so carry on
 980
 981
 982             Just vol_amode  ->  -- Aha! It's volatile
 983                                save_var var vol_amode   `thenFC` \ abs_c ->
 984                                save_em vars             `thenFC` \ abs_cs ->
 985                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 986
 987     save_var var vol_amode
 988       | isFollowableRep kind
 989       = allocAStack                     `thenFC` \ a_slot ->
 990         rebindToAStack var a_slot       `thenC`
 991         getSpARelOffset a_slot          `thenFC` \ spa_rel ->
 992         returnFC (CAssign (CVal spa_rel kind) vol_amode)
 993       | otherwise
 994       = allocBStack (getPrimRepSize kind)       `thenFC` \ b_slot ->
 995         rebindToBStack var b_slot       `thenC`
 996         getSpBRelOffset b_slot          `thenFC` \ spb_rel ->
 997         returnFC (CAssign (CVal spb_rel kind) vol_amode)
 998       where
 999         kind = getAmodeRep vol_amode
1000
1001 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
1002 saveReturnAddress
1003   = getEndOfBlockInfo                `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
1004
1005       -- See if it is volatile
1006     case sequel of
1007       InRetReg ->     -- Yes, it's volatile
1008                    allocBStack retPrimRepSize    `thenFC` \ b_slot ->
1009                    getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
1010
1011                    returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
1012                              CAssign (CVal spb_rel RetRep) (CReg RetReg))
1013
1014       UpdateCode _ ->   -- It's non-volatile all right, but we still need
1015                         -- to allocate a B-stack slot for it, *solely* to make
1016                         -- sure that update frames for different values do not
1017                         -- appear adjacent on the B stack. This makes sure
1018                         -- that B-stack squeezing works ok.
1019                         -- See note below
1020                    allocBStack retPrimRepSize    `thenFC` \ b_slot ->
1021                    returnFC (eob_info, AbsCNop)
1022
1023       other ->           -- No, it's non-volatile, so do nothing
1024                    returnFC (eob_info, AbsCNop)
1025 \end{code}
1026
1027 Note about B-stack squeezing.  Consider the following:`
1028
1029         y = [...] \u [] -> ...
1030         x = [y]   \u [] -> case y of (a,b) -> a
1031
1032 The code for x will push an update frame, and then enter y.  The code
1033 for y will push another update frame.  If the B-stack-squeezer then
1034 wakes up, it will see two update frames right on top of each other,
1035 and will combine them.  This is WRONG, of course, because x's value is
1036 not the same as y's.
1037
1038 The fix implemented above makes sure that we allocate an (unused)
1039 B-stack slot before entering y.  You can think of this as holding the
1040 saved value of RetAddr, which (after pushing x's update frame will be
1041 some update code ptr).  The compiler is clever enough to load the
1042 static update code ptr into RetAddr before entering ~a~, but the slot
1043 is still there to separate the update frames.
1044
1045 When we save the current cost centre (which is done for lexical
1046 scoping), we allocate a free B-stack location, and return (a)~the
1047 virtual offset of the location, to pass on to the alternatives, and
1048 (b)~the assignment to do the save (just as for @saveVolatileVars@).
1049
1050 \begin{code}
1051 saveCurrentCostCentre ::
1052         FCode (Maybe VirtualSpBOffset,  -- Where we decide to store it
1053                                         --   Nothing if not lexical CCs
1054                AbstractC)               -- Assignment to save it
1055                                         --   AbsCNop if not lexical CCs
1056
1057 saveCurrentCostCentre
1058   = let
1059         doing_profiling = opt_SccProfilingOn
1060     in
1061     if not doing_profiling then
1062         returnFC (Nothing, AbsCNop)
1063     else
1064         allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
1065         getSpBRelOffset b_slot                   `thenFC` \ spb_rel ->
1066         returnFC (Just b_slot,
1067                   CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
1068
1069 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1070
1071 restoreCurrentCostCentre Nothing
1072  = returnFC AbsCNop
1073 restoreCurrentCostCentre (Just b_slot)
1074  = getSpBRelOffset b_slot                        `thenFC` \ spb_rel ->
1075    freeBStkSlot b_slot                           `thenC`
1076    returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1077     -- we use the RESTORE_CCC macro, rather than just
1078     -- assigning into CurCostCentre, in case RESTORE_CCC
1079     -- has some sanity-checking in it.
1080 \end{code}
1081
1082
1083 %************************************************************************
1084 %*                                                                      *
1085 \subsection[CgCase-return-vec]{Building a return vector}
1086 %*                                                                      *
1087 %************************************************************************
1088
1089 Build a return vector, and return a suitable label addressing
1090 mode for it.
1091
1092 \begin{code}
1093 mkReturnVector :: Unique
1094                -> Type
1095                -> [(ConTag, AbstractC)] -- Branch codes
1096                -> AbstractC             -- Default case
1097                -> FCode CAddrMode
1098
1099 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1100   = let
1101      (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1102
1103       UnvectoredReturn _ ->
1104         (CUnVecLbl ret_label vtbl_label,
1105          absC (CRetUnVector vtbl_label
1106                             (CLabelledCode ret_label
1107                                            (mkAlgAltsCSwitch (CReg TagReg)
1108                                                              tagged_alt_absCs
1109                                                              deflt_absC))));
1110       VectoredReturn table_size ->
1111         (CLbl vtbl_label DataPtrRep,
1112          absC (CRetVector vtbl_label
1113                         -- must restore cc before each alt, if required
1114                           (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1115                           deflt_absC))
1116
1117 -- Leave nops and comments in for now; they are eliminated
1118 -- lazily as it's printed.
1119 --                        (case (nonemptyAbsC deflt_absC) of
1120 --                              Nothing  -> AbsCNop
1121 --                              Just def -> def)
1122
1123     } in
1124     vtbl_body                                               `thenC`
1125     returnFC return_vec_amode
1126     -- )
1127   where
1128
1129     (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
1130               Just xx -> xx
1131               Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
1132
1133     vtbl_label = mkVecTblLabel uniq
1134     ret_label = mkReturnPtLabel uniq
1135
1136     mk_vector_entry :: ConTag -> Maybe CAddrMode
1137     mk_vector_entry tag
1138       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1139              []     -> Nothing
1140              [absC] -> Just (CCode absC)
1141              _      -> panic "mkReturnVector: too many"
1142 \end{code}
1143
1144 %************************************************************************
1145 %*                                                                      *
1146 \subsection[CgCase-utils]{Utilities for handling case expressions}
1147 %*                                                                      *
1148 %************************************************************************
1149
1150 @possibleHeapCheck@ tests a flag passed in to decide whether to
1151 do a heap check or not.
1152
1153 \begin{code}
1154 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1155
1156 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1157 possibleHeapCheck NoGC        _    _         code = code
1158 \end{code}
1159
1160 Select a restricted set of registers based on a usage mask.
1161
1162 \begin{code}
1163 selectByMask []         []         = []
1164 selectByMask (True:ms)  (x:xs) = x : selectByMask ms xs
1165 selectByMask (False:ms) (x:xs) = selectByMask ms xs
1166 \end{code}