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