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