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