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