ghc/compiler/codeGen/CgCase.lhs

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