ghc/compiler/codeGen/CgCase.lhs

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