ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.64 2003/07/02 13:18:24 simonpj Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgCase]{Converting @StgCase@ expressions}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgCase ( cgCase, saveVolatileVarsAndRegs,
  14                 mkRetDirectTarget, restoreCurrentCostCentre
  15         ) where
  16
  17 #include "HsVersions.h"
  18
  19 import {-# SOURCE #-} CgExpr  ( cgExpr )
  20
  21 import CgMonad
  22 import StgSyn
  23 import AbsCSyn
  24
  25 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
  26 import CgBindery        ( getVolatileRegs, getArgAmodes,
  27                           bindNewToReg, bindNewToTemp,
  28                           getCAddrModeAndInfo,
  29                           rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
  30                           buildContLivenessMask, nukeDeadBindings,
  31                         )
  32 import CgCon            ( bindConArgs, bindUnboxedTupleComponents )
  33 import CgHeapery        ( altHeapCheck, unbxTupleHeapCheck )
  34 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg,
  35                           CtrlReturnConvention(..)
  36                         )
  37 import CgStackery       ( allocPrimStack, allocStackTop,
  38                           deAllocStackTop, freeStackSlots, dataStackSlots
  39                         )
  40 import CgTailCall       ( performTailCall )
  41 import CgUsages         ( getSpRelOffset )
  42 import CLabel           ( mkVecTblLabel, mkClosureTblLabel,
  43                           mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
  44                         )
  45 import ClosureInfo      ( mkLFArgument )
  46 import CmdLineOpts      ( opt_SccProfilingOn )
  47 import Id               ( Id, idName, isDeadBinder )
  48 import DataCon          ( dataConTag, fIRST_TAG, ConTag )
  49 import VarSet           ( varSetElems )
  50 import CoreSyn          ( AltCon(..) )
  51 import PrimOp           ( primOpOutOfLine, PrimOp(..) )
  52 import PrimRep          ( getPrimRepSize, retPrimRepSize, PrimRep(..)
  53                         )
  54 import TyCon            ( TyCon, isEnumerationTyCon, tyConPrimRep       )
  55 import Unique           ( Unique, Uniquable(..), newTagUnique )
  56 import Util             ( only )
  57 import List             ( sortBy )
  58 import Outputable
  59 \end{code}
  60
  61 \begin{code}
  62 data GCFlag
  63   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  64                 -- tidy before the code for the scrutinee.
  65
  66   | NoGC        -- The scrutinee is a primitive value, or a call to a
  67                 -- primitive op which does no GC.  Hence the case can
  68                 -- be done inline, without tidying up first.
  69 \end{code}
  70
  71 It is quite interesting to decide whether to put a heap-check
  72 at the start of each alternative.  Of course we certainly have
  73 to do so if the case forces an evaluation, or if there is a primitive
  74 op which can trigger GC.
  75
  76 A more interesting situation is this:
  77
  78  \begin{verbatim}
  79         !A!;
  80         ...A...
  81         case x# of
  82           0#      -> !B!; ...B...
  83           default -> !C!; ...C...
  84  \end{verbatim}
  85
  86 where \tr{!x!} indicates a possible heap-check point. The heap checks
  87 in the alternatives {\em can} be omitted, in which case the topmost
  88 heapcheck will take their worst case into account.
  89
  90 In favour of omitting \tr{!B!}, \tr{!C!}:
  91
  92  - {\em May} save a heap overflow test,
  93         if ...A... allocates anything.  The other advantage
  94         of this is that we can use relative addressing
  95         from a single Hp to get at all the closures so allocated.
  96
  97  - No need to save volatile vars etc across the case
  98
  99 Against:
 100
 101   - May do more allocation than reqd.  This sometimes bites us
 102         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 103         worst-casing is done, because many many calls to nfib are leaf calls
 104         which don't need to allocate anything.
 105
 106         This never hurts us if there is only one alternative.
 107
 108 \begin{code}
 109 cgCase  :: StgExpr
 110         -> StgLiveVars
 111         -> StgLiveVars
 112         -> Id
 113         -> SRT
 114         -> AltType
 115         -> [StgAlt]
 116         -> Code
 117 \end{code}
 118
 119 Special case #1: case of literal.
 120
 121 \begin{code}
 122 cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
 123        alt_type@(PrimAlt tycon) alts
 124   = bindNewToTemp bndr                  `thenFC` \ tmp_amode ->
 125     absC (CAssign tmp_amode (CLit lit)) `thenC`
 126     cgPrimAlts NoGC tmp_amode alts alt_type
 127 \end{code}
 128
 129 Special case #2: scrutinising a primitive-typed variable.       No
 130 evaluation required.  We don't save volatile variables, nor do we do a
 131 heap-check in the alternatives.  Instead, the heap usage of the
 132 alternatives is worst-cased and passed upstream.  This can result in
 133 allocating more heap than strictly necessary, but it will sometimes
 134 eliminate a heap check altogether.
 135
 136 \begin{code}
 137 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 138        alt_type@(PrimAlt tycon) alts
 139
 140   = -- Careful! we can't just bind the default binder to the same thing
 141     -- as the scrutinee, since it might be a stack location, and having
 142     -- two bindings pointing at the same stack locn doesn't work (it
 143     -- confuses nukeDeadBindings).  Hence, use a new temp.
 144     getCAddrMode v                      `thenFC` \ amode ->
 145     bindNewToTemp bndr                  `thenFC` \ tmp_amode ->
 146     absC (CAssign tmp_amode amode)      `thenC`
 147     cgPrimAlts NoGC tmp_amode alts alt_type
 148 \end{code}
 149
 150 Special case #3: inline PrimOps.
 151
 152 \begin{code}
 153 cgCase (StgOpApp op@(StgPrimOp primop) args _)
 154        live_in_whole_case live_in_alts bndr srt alt_type alts
 155   | not (primOpOutOfLine primop)
 156   =     -- Get amodes for the arguments and results
 157     getArgAmodes args                   `thenFC` \ arg_amodes ->
 158     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 159
 160     case alt_type of
 161       PrimAlt tycon     -- PRIMITIVE ALTS
 162         -> bindNewToTemp bndr                                   `thenFC` \ tmp_amode ->
 163            absC (COpStmt [tmp_amode] op arg_amodes vol_regs)    `thenC`
 164                          -- Note: no liveness arg
 165            cgPrimAlts NoGC tmp_amode alts alt_type
 166
 167       UbxTupAlt tycon   -- UNBOXED TUPLE ALTS
 168         ->      -- No heap check, no yield, just get in there and do it.
 169                 -- NB: the case binder isn't bound to anything;
 170                 --     it has a unboxed tuple type
 171            mapFCs bindNewToTemp res_ids                         `thenFC` \ res_tmps ->
 172            absC (COpStmt res_tmps op arg_amodes vol_regs)       `thenC`
 173            cgExpr rhs
 174         where
 175            [(_, res_ids, _, rhs)] = alts
 176
 177       AlgAlt tycon      -- ENUMERATION TYPE RETURN
 178         -> ASSERT( isEnumerationTyCon tycon )
 179            do_enum_primop primop                `thenFC` \ tag_amode ->
 180
 181                 -- Bind the default binder if necessary
 182                 -- (avoiding it avoids the assignment)
 183                 -- The deadness info is set by StgVarInfo
 184            (if (isDeadBinder bndr)
 185                 then nopC
 186                 else bindNewToTemp bndr         `thenFC` \ tmp_amode ->
 187                      absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
 188            )                                    `thenC`
 189
 190                 -- Compile the alts
 191            cgAlgAlts NoGC (getUnique bndr)
 192                      Nothing{-cc_slot-} False{-no semi-tagging-}
 193                      (AlgAlt tycon) alts        `thenFC` \ tagged_alts ->
 194
 195                 -- Do the switch
 196            absC (mkAlgAltsCSwitch tag_amode tagged_alts)
 197         where
 198            do_enum_primop :: PrimOp -> FCode CAddrMode  -- Returns amode for result
 199            do_enum_primop TagToEnumOp   -- No code!
 200               = returnFC (only arg_amodes)
 201
 202            do_enum_primop primop
 203               = absC (COpStmt [tag_amode] op arg_amodes vol_regs)       `thenC`
 204                 returnFC tag_amode
 205               where
 206                 tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
 207                         -- Being a bit short of uniques for temporary variables here,
 208                         -- we use newTagUnique to generate a new unique from the case
 209                         -- binder.  The case binder's unique will presumably have
 210                         -- the 'c' tag (generated by CoreToStg), so we just change
 211                         -- its tag to 'C' (for 'case') to ensure it doesn't clash with
 212                         -- anything else.
 213                         -- We can't use the unique from the case binder, becaus e
 214                         -- this is used to hold the actual result closure
 215                         -- (via the call to bindNewToTemp)
 216
 217       other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
 218 \end{code}
 219
 220 TODO: Case-of-case of primop can probably be done inline too (but
 221 maybe better to translate it out beforehand).  See
 222 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
 223 4.02).
 224
 225 Special case: scrutinising a non-primitive variable.
 226 This can be done a little better than the general case, because
 227 we can reuse/trim the stack slot holding the variable (if it is in one).
 228
 229 \begin{code}
 230 cgCase (StgApp fun args)
 231         live_in_whole_case live_in_alts bndr srt alt_type alts
 232   = getCAddrModeAndInfo fun             `thenFC` \ (fun', fun_amode, lf_info) ->
 233     getArgAmodes args                   `thenFC` \ arg_amodes ->
 234
 235         -- Nuking dead bindings *before* calculating the saves is the
 236         -- value-add here.  We might end up freeing up some slots currently
 237         -- occupied by variables only required for the call.
 238         -- NOTE: we need to look up the variables used in the call before
 239         -- doing this, because some of them may not be in the environment
 240         -- afterward.
 241     nukeDeadBindings live_in_alts       `thenC`
 242     saveVolatileVarsAndRegs live_in_alts
 243                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 244
 245     forkEval alts_eob_info
 246         ( allocStackTop retPrimRepSize
 247          `thenFC` \_ -> nopC )
 248         ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
 249           cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
 250                                          `thenFC` \ scrut_eob_info ->
 251
 252     setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)    $
 253     performTailCall fun' fun_amode lf_info arg_amodes save_assts
 254 \end{code}
 255
 256 Note about return addresses: we *always* push a return address, even
 257 if because of an optimisation we end up jumping direct to the return
 258 code (not through the address itself).  The alternatives always assume
 259 that the return address is on the stack.  The return address is
 260 required in case the alternative performs a heap check, since it
 261 encodes the liveness of the slots in the activation record.
 262
 263 On entry to the case alternative, we can re-use the slot containing
 264 the return address immediately after the heap check.  That's what the
 265 deAllocStackTop call is doing above.
 266
 267 Finally, here is the general case.
 268
 269 \begin{code}
 270 cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
 271   =     -- Figure out what volatile variables to save
 272     nukeDeadBindings live_in_whole_case `thenC`
 273
 274     saveVolatileVarsAndRegs live_in_alts
 275                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 276
 277     -- Save those variables right now!
 278     absC save_assts                     `thenC`
 279
 280     -- generate code for the alts
 281     forkEval alts_eob_info
 282         (nukeDeadBindings live_in_alts `thenC`
 283          allocStackTop retPrimRepSize   -- space for retn address
 284          `thenFC` \_ -> nopC
 285          )
 286         (deAllocStackTop retPrimRepSize `thenFC` \_ ->
 287          cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
 288
 289     setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)    $
 290     cgExpr expr
 291 \end{code}
 292
 293 There's a lot of machinery going on behind the scenes to manage the
 294 stack pointer here.  forkEval takes the virtual Sp and free list from
 295 the first argument, and turns that into the *real* Sp for the second
 296 argument.  It also uses this virtual Sp as the args-Sp in the EOB info
 297 returned, so that the scrutinee will trim the real Sp back to the
 298 right place before doing whatever it does.
 299   --SDM (who just spent an hour figuring this out, and didn't want to
 300          forget it).
 301
 302 Why don't we push the return address just before evaluating the
 303 scrutinee?  Because the slot reserved for the return address might
 304 contain something useful, so we wait until performing a tail call or
 305 return before pushing the return address (see
 306 CgTailCall.pushReturnAddress).
 307
 308 This also means that the environment doesn't need to know about the
 309 free stack slot for the return address (for generating bitmaps),
 310 because we don't reserve it until just before the eval.
 311
 312 TODO!!  Problem: however, we have to save the current cost centre
 313 stack somewhere, because at the eval point the current CCS might be
 314 different.  So we pick a free stack slot and save CCCS in it.  The
 315 problem with this is that this slot isn't recorded as free/unboxed in
 316 the environment, so a case expression in the scrutinee will have the
 317 wrong bitmap attached.  Fortunately we don't ever seem to see
 318 case-of-case at the back end.  One solution might be to shift the
 319 saved CCS to the correct place in the activation record just before
 320 the jump.
 321         --SDM
 322
 323 (one consequence of the above is that activation records on the stack
 324 don't follow the layout of closures when we're profiling.  The CCS
 325 could be anywhere within the record).
 326
 327 \begin{code}
 328 maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
 329    = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
 330 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection[CgCase-alts]{Alternatives}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 @cgEvalAlts@ returns an addressing mode for a continuation for the
 340 alternatives of a @case@, used in a context when there
 341 is some evaluation to be done.
 342
 343 \begin{code}
 344 cgEvalAlts :: Maybe VirtualSpOffset     -- Offset of cost-centre to be restored, if any
 345            -> Id
 346            -> SRT                       -- SRT for the continuation
 347            -> AltType
 348            -> [StgAlt]
 349            -> FCode Sequel      -- Any addr modes inside are guaranteed
 350                                 -- to be a label so that we can duplicate it
 351                                 -- without risk of duplicating code
 352
 353 cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
 354   =     -- Unboxed tuple case
 355         -- By now, the simplifier should have have turned it
 356         -- into         case e of (# a,b #) -> e
 357         -- There shouldn't be a
 358         --              case e of DEFAULT -> e
 359     ASSERT2( case con of { DataAlt _ -> True; other -> False },
 360              text "cgEvalAlts: dodgy case of unboxed tuple type" )
 361
 362     forkAbsC (  -- forkAbsC for the RHS, so that the envt is
 363                 -- not changed for the mkRetDirect call
 364         restoreCurrentCostCentre cc_slot        `thenC`
 365         bindUnboxedTupleComponents args         `thenFC` \ (live_regs, ptrs, nptrs, _) ->
 366                 -- Generate a heap check if necessary
 367         unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop $
 368                 -- And finally the code for the alternative
 369         cgExpr rhs
 370     )                                           `thenFC` \ abs_c ->
 371     mkRetDirectTarget bndr abs_c srt            `thenFC` \ lbl ->
 372     returnFC (CaseAlts lbl Nothing False)
 373
 374 cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
 375   = forkAbsC (  -- forkAbsC for the RHS, so that the envt is
 376                 -- not changed for the mkRetDirect call
 377         restoreCurrentCostCentre cc_slot                `thenC`
 378         bindNewToReg bndr reg (mkLFArgument bndr)       `thenC`
 379         cgPrimAlts GCMayHappen (CReg reg) alts alt_type
 380     )                                           `thenFC` \ abs_c ->
 381     mkRetDirectTarget bndr abs_c srt            `thenFC` \ lbl ->
 382     returnFC (CaseAlts lbl Nothing False)
 383   where
 384     reg  = dataReturnConvPrim kind
 385     kind = tyConPrimRep tycon
 386
 387 cgEvalAlts cc_slot bndr srt alt_type alts
 388   =     -- Algebraic and polymorphic case
 389         -- Bind the default binder
 390     bindNewToReg bndr node (mkLFArgument bndr) `thenC`
 391
 392         -- Generate sequel info for use downstream
 393         -- At the moment, we only do it if the type is vector-returnable.
 394         -- Reason: if not, then it costs extra to label the
 395         -- alternatives, because we'd get return code like:
 396         --
 397         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 398         --
 399         -- which is worse than having the alt code in the switch statement
 400
 401     let ret_conv = case alt_type of
 402                         AlgAlt tc -> ctrlReturnConvAlg tc
 403                         PolyAlt   -> UnvectoredReturn 0
 404
 405         use_labelled_alts = case ret_conv of
 406                                 VectoredReturn _ -> True
 407                                 _                -> False
 408
 409         semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
 410
 411     in
 412     cgAlgAlts GCMayHappen (getUnique bndr)
 413               cc_slot use_labelled_alts
 414               alt_type alts                     `thenFC` \ tagged_alt_absCs ->
 415
 416     mkRetVecTarget bndr tagged_alt_absCs
 417                    srt ret_conv                 `thenFC` \ return_vec ->
 418
 419     returnFC (CaseAlts return_vec semi_tagged_stuff False)
 420 \end{code}
 421
 422
 423 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 424 we  do  an inlining of the  case  no separate  functions  for returning are
 425 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 426 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 427 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 428
 429 %************************************************************************
 430 %*                                                                      *
 431 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 In @cgAlgAlts@, none of the binders in the alternatives are
 436 assumed to be yet bound.
 437
 438 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 439 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 440 beginning of  each alternative. Normally we  want that. The  only exception
 441 are inlined alternatives.
 442
 443 \begin{code}
 444 cgAlgAlts :: GCFlag
 445        -> Unique
 446        -> Maybe VirtualSpOffset
 447        -> Bool                          -- True <=> branches must be labelled
 448                                         --      (used for semi-tagging)
 449        -> AltType                       -- ** AlgAlt or PolyAlt only **
 450        -> [StgAlt]                      -- The alternatives
 451        -> FCode [(AltCon, AbstractC)]   -- The branches
 452
 453 cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
 454   = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
 455              | alt <- alts]
 456
 457 cgAlgAlt :: GCFlag
 458          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 459          -> AltType                                     -- ** AlgAlt or PolyAlt only **
 460          -> StgAlt
 461          -> FCode (AltCon, AbstractC)
 462
 463 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 464          alt_type (con, args, use_mask, rhs)
 465   = getAbsC (bind_con_args con args             `thenFC` \ _ ->
 466              restoreCurrentCostCentre cc_slot   `thenC`
 467              maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
 468     )                                           `thenFC` \ abs_c ->
 469     let
 470         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 471                     | otherwise         = abs_c
 472     in
 473     returnFC (con, final_abs_c)
 474   where
 475     lbl = case con of
 476             DataAlt dc -> mkAltLabel uniq (dataConTag dc)
 477             DEFAULT    -> mkDefaultLabel uniq
 478             other      -> pprPanic "cgAlgAlt" (ppr con)
 479
 480     bind_con_args DEFAULT      args = nopC
 481     bind_con_args (DataAlt dc) args = bindConArgs dc args
 482 \end{code}
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 Turgid-but-non-monadic code to conjure up the required info from
 491 algebraic case alternatives for semi-tagging.
 492
 493 \begin{code}
 494 cgSemiTaggedAlts :: Bool        -- True <=> use semitagging: each alt will be labelled
 495                  -> Id
 496                  -> [StgAlt]
 497                  -> SemiTaggingStuff
 498
 499 cgSemiTaggedAlts False binder alts
 500   = Nothing
 501 cgSemiTaggedAlts True binder alts
 502   = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
 503           case head alts of
 504             (DEFAULT, _, _, _) -> Just st_deflt
 505             other              -> Nothing)
 506   where
 507     uniq = getUnique binder
 508
 509     st_deflt = (binder,
 510                 (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 511                  mkDefaultLabel uniq))
 512
 513     st_alt con args     -- Ha!  Nothing to do; Node already points to the thing
 514       =  (con_tag,
 515            (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 516                 [mkIntCLit (length args)], -- how big the thing in the heap is
 517              join_label)
 518             )
 519       where
 520         con_tag    = dataConTag con
 521         join_label = mkAltLabel uniq con_tag
 522
 523
 524 tagToClosure :: TyCon -> CAddrMode -> CAddrMode
 525 -- Primops returning an enumeration type (notably Bool)
 526 -- actually return an index into
 527 -- the table of closures for the enumeration type
 528 tagToClosure tycon tag_amode
 529   = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
 530   where
 531     closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
 532 \end{code}
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection[CgCase-prim-alts]{Primitive alternatives}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 @cgPrimAlts@ generates suitable a @CSwitch@
 541 for dealing with the alternatives of a primitive @case@, given an
 542 addressing mode for the thing to scrutinise.  It also keeps track of
 543 the maximum stack depth encountered down any branch.
 544
 545 As usual, no binders in the alternatives are yet bound.
 546
 547 \begin{code}
 548 cgPrimAlts :: GCFlag
 549            -> CAddrMode -- Scrutinee
 550            -> [StgAlt]  -- Alternatives
 551            -> AltType
 552            -> Code
 553 -- INVARIANT: the default binder is already bound
 554 cgPrimAlts gc_flag scrutinee alts alt_type
 555   = forkAlts (map (cgPrimAlt gc_flag alt_type) alts)    `thenFC` \ tagged_absCs ->
 556     let
 557         ((DEFAULT, deflt_absC) : others) = tagged_absCs         -- There is always a default
 558         alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
 559     in
 560     absC (CSwitch scrutinee alt_absCs deflt_absC)
 561         -- CSwitch does sensible things with one or zero alternatives
 562
 563 cgPrimAlt :: GCFlag
 564           -> AltType
 565           -> StgAlt                     -- The alternative
 566           -> FCode (AltCon, AbstractC)  -- Its compiled form
 567
 568 cgPrimAlt gc_flag alt_type (con, [], [], rhs)
 569   = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
 570     getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))   `thenFC` \ abs_c ->
 571     returnFC (con, abs_c)
 572 \end{code}
 573
 574
 575 %************************************************************************
 576 %*                                                                      *
 577 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 578 %*                                                                      *
 579 %************************************************************************
 580
 581 \begin{code}
 582 maybeAltHeapCheck
 583         :: GCFlag
 584         -> AltType      -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
 585         -> Code         -- Continuation
 586         -> Code
 587 maybeAltHeapCheck NoGC        _        code = code
 588 maybeAltHeapCheck GCMayHappen alt_type code
 589   =     -- HWL: maybe need yield here
 590         -- yield [node] True    -- XXX live regs wrong
 591     altHeapCheck alt_type code
 592
 593 saveVolatileVarsAndRegs
 594     :: StgLiveVars                    -- Vars which should be made safe
 595     -> FCode (AbstractC,              -- Assignments to do the saves
 596               EndOfBlockInfo,         -- sequel for the alts
 597               Maybe VirtualSpOffset)  -- Slot for current cost centre
 598
 599 saveVolatileVarsAndRegs vars
 600   = saveVolatileVars vars       `thenFC` \ var_saves ->
 601     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 602     getEndOfBlockInfo           `thenFC` \ eob_info ->
 603     returnFC (mkAbstractCs [var_saves, cc_save],
 604               eob_info,
 605               maybe_cc_slot)
 606
 607
 608 saveVolatileVars :: StgLiveVars         -- Vars which should be made safe
 609                  -> FCode AbstractC     -- Assignments to to the saves
 610
 611 saveVolatileVars vars
 612   = save_em (varSetElems vars)
 613   where
 614     save_em [] = returnFC AbsCNop
 615
 616     save_em (var:vars)
 617       = getCAddrModeIfVolatile var `thenFC` \ v ->
 618         case v of
 619             Nothing         -> save_em vars -- Non-volatile, so carry on
 620
 621
 622             Just vol_amode  ->  -- Aha! It's volatile
 623                                save_var var vol_amode   `thenFC` \ abs_c ->
 624                                save_em vars             `thenFC` \ abs_cs ->
 625                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 626
 627     save_var var vol_amode
 628       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 629         rebindToStack var slot          `thenC`
 630         getSpRelOffset slot             `thenFC` \ sp_rel ->
 631         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 632       where
 633         kind = getAmodeRep vol_amode
 634 \end{code}
 635
 636 ---------------------------------------------------------------------------
 637
 638 When we save the current cost centre (which is done for lexical
 639 scoping), we allocate a free stack location, and return (a)~the
 640 virtual offset of the location, to pass on to the alternatives, and
 641 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 642
 643 \begin{code}
 644 saveCurrentCostCentre ::
 645         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 646                AbstractC)               -- Assignment to save it
 647
 648 saveCurrentCostCentre
 649   = if not opt_SccProfilingOn then
 650         returnFC (Nothing, AbsCNop)
 651     else
 652         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 653         dataStackSlots [slot]                         `thenC`
 654         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 655         returnFC (Just slot,
 656                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 657
 658 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Code
 659 restoreCurrentCostCentre Nothing = nopC
 660 restoreCurrentCostCentre (Just slot)
 661  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 662    freeStackSlots [slot]                         `thenC`
 663    absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 664     -- we use the RESTORE_CCCS macro, rather than just
 665     -- assigning into CurCostCentre, in case RESTORE_CCCS
 666     -- has some sanity-checking in it.
 667 \end{code}
 668
 669 %************************************************************************
 670 %*                                                                      *
 671 \subsection[CgCase-return-vec]{Building a return vector}
 672 %*                                                                      *
 673 %************************************************************************
 674
 675 Build a return vector, and return a suitable label addressing
 676 mode for it.
 677
 678 \begin{code}
 679 mkRetDirectTarget :: Id                 -- Used for labelling only
 680                   -> AbstractC          -- Return code
 681                   -> SRT                -- Live CAFs in return code
 682                   -> FCode CAddrMode    -- Emit the labelled return block,
 683                                         -- and return its label
 684 mkRetDirectTarget bndr abs_c srt
 685   = buildContLivenessMask bndr                          `thenFC` \ liveness ->
 686     getSRTInfo name srt                                 `thenFC` \ srt_info ->
 687     absC (CRetDirect uniq abs_c srt_info liveness)      `thenC`
 688     return lbl
 689   where
 690     name = idName bndr
 691     uniq = getUnique name
 692     lbl  = CLbl (mkReturnInfoLabel uniq) RetRep
 693 \end{code}
 694
 695 \begin{code}
 696 mkRetVecTarget :: Id                    -- Just for its unique
 697                -> [(AltCon, AbstractC)] -- Branch codes
 698                -> SRT                   -- Continuation's SRT
 699                -> CtrlReturnConvention
 700                -> FCode CAddrMode
 701
 702 mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
 703   = ASSERT( null other_alts )
 704     mkRetDirectTarget bndr deflt_absC srt
 705   where
 706     ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
 707
 708 mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
 709   = mkRetDirectTarget bndr switch_absC srt
 710   where
 711          -- Find the tag explicitly rather than using tag_reg for now.
 712          -- on architectures with lots of regs the tag will be loaded
 713          -- into tag_reg by the code doing the returning.
 714     tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 715     switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
 716
 717
 718 mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
 719   = buildContLivenessMask bndr  `thenFC` \ liveness ->
 720     getSRTInfo name srt         `thenFC` \ srt_info ->
 721     let
 722         ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
 723     in
 724     absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector)     `thenC`
 725                  -- Alts come first, because we don't want to declare all the symbols
 726
 727     return (CLbl vtbl_lbl DataPtrRep)
 728   where
 729     tags         = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
 730     vector_table = map mk_vector_entry tags
 731     alts_absCs   = map snd (sortBy cmp tagged_alt_absCs)
 732                         -- The sort is unnecessary; just there for now
 733                         -- to make the new order the same as the old
 734     (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
 735     (DEFAULT,_) `cmp` _   = GT
 736     (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
 737     (DataAlt d1,_) `cmp` (DEFAULT, _)   = LT
 738         -- Others impossible
 739
 740     name       = idName bndr
 741     uniq       = getUnique name
 742     vtbl_lbl   = mkVecTblLabel uniq
 743
 744     deflt_lbl :: CAddrMode
 745     deflt_lbl = case tagged_alt_absCs of
 746                    (DEFAULT, abs_c) : _ -> get_block_label abs_c
 747                    other                -> mkIntCLit 0
 748                         -- 'other' case: the simplifier might have eliminated a case
 749                         --                so we may have e.g. case xs of
 750                         --                                       [] -> e
 751                         -- In that situation the default should never be taken,
 752                         -- so we just use '0' (=> seg fault if used)
 753
 754     mk_vector_entry :: ConTag -> CAddrMode
 755     mk_vector_entry tag
 756       = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
 757                 -- The comprehension neatly, and correctly, ignores the DEFAULT
 758              []      -> deflt_lbl
 759              [abs_c] -> get_block_label abs_c
 760              _       -> panic "mkReturnVector: too many"
 761
 762     get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
 763 \end{code}