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