ghc/compiler/codeGen/CgCase.lhs

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