ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgCase]{Converting @StgCase@ expressions}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
  14         ) where
  15
  16 #include "HsVersions.h"
  17
  18 import {-# SOURCE #-} CgExpr  ( cgExpr )
  19
  20 import CgMonad
  21 import StgSyn
  22 import AbsCSyn
  23
  24 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
  25                           getAmodeRep, nonemptyAbsC
  26                         )
  27 import CgUpdate         ( reserveSeqFrame )
  28 import CgBindery        ( getVolatileRegs, getArgAmodes,
  29                           bindNewToReg, bindNewToTemp,
  30                           bindNewPrimToAmode, getCAddrModeAndInfo,
  31                           rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
  32                           buildContLivenessMask, nukeDeadBindings,
  33                         )
  34 import CgCon            ( bindConArgs, bindUnboxedTupleComponents )
  35 import CgHeapery        ( altHeapCheck )
  36 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg,
  37                           CtrlReturnConvention(..)
  38                         )
  39 import CgStackery       ( allocPrimStack, allocStackTop,
  40                           deAllocStackTop, freeStackSlots, dataStackSlots
  41                         )
  42 import CgTailCall       ( tailCallFun )
  43 import CgUsages         ( getSpRelOffset )
  44 import CLabel           ( mkVecTblLabel, mkClosureTblLabel,
  45                           mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
  46                         )
  47 import ClosureInfo      ( mkLFArgument )
  48 import CmdLineOpts      ( opt_SccProfilingOn )
  49 import Id               ( Id, idPrimRep, isDeadBinder )
  50 import DataCon          ( DataCon, dataConTag, fIRST_TAG, ConTag )
  51 import VarSet           ( varSetElems )
  52 import Literal          ( Literal )
  53 import PrimOp           ( primOpOutOfLine, PrimOp(..) )
  54 import PrimRep          ( getPrimRepSize, retPrimRepSize, PrimRep(..)
  55                         )
  56 import TyCon            ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
  57 import Unique           ( Unique, Uniquable(..), newTagUnique )
  58 import Maybes           ( maybeToBool )
  59 import Util
  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         -> StgCaseAlts
 117         -> Code
 118 \end{code}
 119
 120 Special case #1:  PrimOps returning enumeration types.
 121
 122 For enumeration types, we invent a temporary (builtin-unique 1) to
 123 hold the tag, and cross our fingers that this doesn't clash with
 124 anything else.  Builtin-unique 0 is used for a similar reason when
 125 compiling enumerated-type primops in CgExpr.lhs.  We can't use the
 126 unique from the case binder, because this is used to hold the actual
 127 closure (when the case binder is live, that is).
 128
 129 There is an extra special case for
 130
 131         case tagToEnum# x of
 132                 ...
 133
 134 which generates no code for the primop, unless x is used in the
 135 alternatives (in which case we lookup the tag in the relevant closure
 136 table to get the closure).
 137
 138 Being a bit short of uniques for temporary variables here, we use
 139 newTagUnique to generate a new unique from the case binder.  The case
 140 binder's unique will presumably have the 'c' tag (generated by
 141 CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
 142 doesn't clash with anything else.
 143
 144 \begin{code}
 145 cgCase (StgPrimApp op args _)
 146        live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
 147   | isEnumerationTyCon tycon
 148   = getArgAmodes args `thenFC` \ arg_amodes ->
 149
 150     let tag_amode = case op of
 151                         TagToEnumOp -> only arg_amodes
 152                         _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
 153
 154         closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
 155     in
 156
 157     case op of {
 158         TagToEnumOp -> nopC;  -- no code!
 159
 160         _ ->    -- Perform the operation
 161                getVolatileRegs live_in_alts     `thenFC` \ vol_regs ->
 162
 163                absC (COpStmt [tag_amode] op
 164                  arg_amodes -- note: no liveness arg
 165                  vol_regs)
 166     }                                           `thenC`
 167
 168         -- bind the default binder if necessary
 169         -- The deadness info is set by StgVarInfo
 170     (if (isDeadBinder bndr)
 171         then nopC
 172         else bindNewToTemp bndr                 `thenFC` \ bndr_amode ->
 173              absC (CAssign bndr_amode closure))
 174                                                 `thenC`
 175
 176         -- compile the alts
 177     cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
 178                 False{-not poly case-} alts deflt
 179                 False{-don't emit yield-}       `thenFC` \ (tagged_alts, deflt_c) ->
 180
 181         -- Do the switch
 182     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 183 \end{code}
 184
 185 Special case #2: inline PrimOps.
 186
 187 \begin{code}
 188 cgCase (StgPrimApp op args _)
 189        live_in_whole_case live_in_alts bndr srt alts
 190   | not (primOpOutOfLine op)
 191   =
 192         -- Get amodes for the arguments and results
 193     getArgAmodes args                   `thenFC` \ arg_amodes ->
 194     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 195
 196     case alts of
 197       StgPrimAlts tycon alts deflt      -- PRIMITIVE ALTS
 198         -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
 199                          op
 200                          arg_amodes     -- note: no liveness arg
 201                          vol_regs)              `thenC`
 202            cgPrimInlineAlts bndr tycon alts deflt
 203
 204       StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
 205         |  isUnboxedTupleTyCon tycon    -- UNBOXED TUPLE ALTS
 206         ->      -- no heap check, no yield, just get in there and do it.
 207            absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
 208                          op
 209                          arg_amodes      -- note: no liveness arg
 210                          vol_regs)              `thenC`
 211            mapFCs bindNewToTemp args `thenFC` \ _ ->
 212            cgExpr rhs
 213
 214       other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
 215 \end{code}
 216
 217 TODO: Case-of-case of primop can probably be done inline too (but
 218 maybe better to translate it out beforehand).  See
 219 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
 220 4.02).
 221
 222 Another special case: scrutinising a primitive-typed variable.  No
 223 evaluation required.  We don't save volatile variables, nor do we do a
 224 heap-check in the alternatives.  Instead, the heap usage of the
 225 alternatives is worst-cased and passed upstream.  This can result in
 226 allocating more heap than strictly necessary, but it will sometimes
 227 eliminate a heap check altogether.
 228
 229 \begin{code}
 230 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 231                         (StgPrimAlts tycon alts deflt)
 232
 233   =
 234     getCAddrMode v              `thenFC` \amode ->
 235
 236     {-
 237        Careful! we can't just bind the default binder to the same thing
 238        as the scrutinee, since it might be a stack location, and having
 239        two bindings pointing at the same stack locn doesn't work (it
 240        confuses nukeDeadBindings).  Hence, use a new temp.
 241     -}
 242     bindNewToTemp bndr                  `thenFC`  \deflt_amode ->
 243     absC (CAssign deflt_amode amode)    `thenC`
 244
 245     cgPrimAlts NoGC amode alts deflt []
 246 \end{code}
 247
 248 Special case: scrutinising a non-primitive variable.
 249 This can be done a little better than the general case, because
 250 we can reuse/trim the stack slot holding the variable (if it is in one).
 251
 252 \begin{code}
 253 cgCase (StgApp fun args)
 254         live_in_whole_case live_in_alts bndr srt alts
 255   = getCAddrModeAndInfo fun                     `thenFC` \ (fun', fun_amode, lf_info) ->
 256     getArgAmodes args                           `thenFC` \ arg_amodes ->
 257
 258        -- Squish the environment
 259     nukeDeadBindings live_in_alts       `thenC`
 260     saveVolatileVarsAndRegs live_in_alts
 261                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 262
 263     allocStackTop retPrimRepSize        `thenFC` \_ ->
 264
 265     forkEval alts_eob_info nopC (
 266              deAllocStackTop retPrimRepSize `thenFC` \_ ->
 267              cgEvalAlts maybe_cc_slot bndr srt alts)
 268                                          `thenFC` \ scrut_eob_info ->
 269
 270     setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info)        $
 271     tailCallFun 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 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 alts) `thenFC` \ scrut_eob_info ->
 306
 307     setEndOfBlockInfo (maybeReserveSeqFrame alts 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 -- We need to reserve a seq frame for a polymorphic case
 347 maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
 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            -> StgCaseAlts
 366            -> FCode Sequel      -- Any addr modes inside are guaranteed
 367                                 -- to be a label so that we can duplicate it
 368                                 -- without risk of duplicating code
 369
 370 cgEvalAlts cc_slot bndr srt alts
 371   =
 372     let uniq = getUnique bndr in
 373
 374     buildContLivenessMask uniq          `thenFC` \ liveness_mask ->
 375
 376     case alts of
 377
 378       -- algebraic alts ...
 379       StgAlgAlts maybe_tycon alts deflt ->
 380
 381            -- bind the default binder (it covers all the alternatives)
 382         bindNewToReg bndr node mkLFArgument      `thenC`
 383
 384         -- Generate sequel info for use downstream
 385         -- At the moment, we only do it if the type is vector-returnable.
 386         -- Reason: if not, then it costs extra to label the
 387         -- alternatives, because we'd get return code like:
 388         --
 389         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 390         --
 391         -- which is worse than having the alt code in the switch statement
 392
 393         let     is_alg          = maybeToBool maybe_tycon
 394                 Just spec_tycon = maybe_tycon
 395         in
 396
 397         -- deal with the unboxed tuple case
 398         if is_alg && isUnboxedTupleTyCon spec_tycon then
 399             case alts of
 400                 [alt] -> let lbl = mkReturnInfoLabel uniq in
 401                          cgUnboxedTupleAlt uniq cc_slot True alt
 402                                 `thenFC` \ abs_c ->
 403                          getSRTLabel `thenFC` \srt_label ->
 404                          absC (CRetDirect uniq abs_c (srt_label, srt)
 405                                         liveness_mask) `thenC`
 406                         returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 407                 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
 408
 409         -- normal algebraic (or polymorphic) case alternatives
 410         else let
 411                 ret_conv | is_alg    = ctrlReturnConvAlg spec_tycon
 412                          | otherwise = UnvectoredReturn 0
 413
 414                 use_labelled_alts = case ret_conv of
 415                                         VectoredReturn _ -> True
 416                                         _                -> False
 417
 418                 semi_tagged_stuff
 419                    = if use_labelled_alts then
 420                         cgSemiTaggedAlts bndr alts deflt -- Just <something>
 421                      else
 422                         Nothing -- no semi-tagging info
 423
 424         in
 425         cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
 426                 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 427
 428         mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
 429                 ret_conv  `thenFC` \ return_vec ->
 430
 431         returnFC (CaseAlts return_vec semi_tagged_stuff)
 432
 433       -- primitive alts...
 434       StgPrimAlts tycon alts deflt ->
 435
 436         -- Restore the cost centre
 437         restoreCurrentCostCentre cc_slot                `thenFC` \ cc_restore ->
 438
 439         -- Generate the switch
 440         getAbsC (cgPrimEvalAlts bndr tycon alts deflt)  `thenFC` \ abs_c ->
 441
 442         -- Generate the labelled block, starting with restore-cost-centre
 443         getSRTLabel                                     `thenFC` \srt_label ->
 444         absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
 445                         (srt_label,srt) liveness_mask)  `thenC`
 446
 447         -- Return an amode for the block
 448         returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 449 \end{code}
 450
 451
 452 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 453 we  do  an inlining of the  case  no separate  functions  for returning are
 454 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 455 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 456 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 In @cgAlgAlts@, none of the binders in the alternatives are
 465 assumed to be yet bound.
 466
 467 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 468 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 469 beginning of  each alternative. Normally we  want that. The  only exception
 470 are inlined alternatives.
 471
 472 \begin{code}
 473 cgAlgAlts :: GCFlag
 474           -> Unique
 475           -> Maybe VirtualSpOffset
 476           -> Bool                               -- True <=> branches must be labelled
 477           -> Bool                               -- True <=> polymorphic case
 478           -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
 479           -> StgCaseDefault                     -- The default
 480           -> Bool                               -- Context switch at alts?
 481           -> FCode ([(ConTag, AbstractC)],      -- The branches
 482                     AbstractC                   -- The default case
 483              )
 484
 485 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
 486           emit_yield{-should a yield macro be emitted?-}
 487
 488   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 489              (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
 490 \end{code}
 491
 492 \begin{code}
 493 cgAlgDefault :: GCFlag
 494              -> Bool                    -- could be a function-typed result?
 495              -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
 496              -> StgCaseDefault          -- input
 497              -> Bool
 498              -> FCode AbstractC         -- output
 499
 500 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
 501   = returnFC AbsCNop
 502
 503 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
 504              (StgBindDefault rhs)
 505           emit_yield{-should a yield macro be emitted?-}
 506
 507   =     -- We have arranged that Node points to the thing
 508     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 509     getAbsC (absC restore_cc `thenC`
 510              -- HWL: maybe need yield here
 511              --(if emit_yield
 512              --   then yield [node] True
 513              --   else absC AbsCNop)                            `thenC`
 514              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 515         -- Node is live, but doesn't need to point at the thing itself;
 516         -- it's ok for Node to point to an indirection or FETCH_ME
 517         -- Hence no need to re-enter Node.
 518     )                                   `thenFC` \ abs_c ->
 519
 520     let
 521         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 522                     | otherwise         = abs_c
 523     in
 524     returnFC final_abs_c
 525   where
 526     lbl = mkDefaultLabel uniq
 527
 528 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 529
 530 cgAlgAlt :: GCFlag
 531          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 532          -> Bool                               -- Context switch at alts?
 533          -> (DataCon, [Id], [Bool], StgExpr)
 534          -> FCode (ConTag, AbstractC)
 535
 536 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 537          emit_yield{-should a yield macro be emitted?-}
 538          (con, args, use_mask, rhs)
 539   =
 540     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 541     getAbsC (absC restore_cc `thenC`
 542              -- HWL: maybe need yield here
 543              -- (if emit_yield
 544              --    then yield [node] True               -- XXX live regs wrong
 545              --    else absC AbsCNop)                               `thenC`
 546              (case gc_flag of
 547                 NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
 548                 GCMayHappen -> bindConArgs con args
 549              )  `thenC`
 550              possibleHeapCheck gc_flag False [node] [] Nothing (
 551              cgExpr rhs)
 552             ) `thenFC` \ abs_c ->
 553     let
 554         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 555                     | otherwise         = abs_c
 556     in
 557     returnFC (tag, final_abs_c)
 558   where
 559     tag = dataConTag con
 560     lbl = mkAltLabel uniq tag
 561
 562 cgUnboxedTupleAlt
 563         :: Unique                       -- unique for label of the alternative
 564         -> Maybe VirtualSpOffset        -- Restore cost centre
 565         -> Bool                         -- ctxt switch
 566         -> (DataCon, [Id], [Bool], StgExpr) -- alternative
 567         -> FCode AbstractC
 568
 569 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
 570   = getAbsC (
 571         bindUnboxedTupleComponents args
 572                       `thenFC` \ (live_regs,tags,stack_res) ->
 573
 574         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 575         absC restore_cc `thenC`
 576
 577         -- HWL: maybe need yield here
 578         -- (if emit_yield
 579         --    then yield live_regs True         -- XXX live regs wrong?
 580         --    else absC AbsCNop)                         `thenC`
 581         let
 582               -- ToDo: could maybe use Nothing here if stack_res is False
 583               -- since the heap-check can just return to the top of the
 584               -- stack.
 585               ret_addr = Just lbl
 586         in
 587
 588         -- free up stack slots containing tags,
 589         freeStackSlots (map fst tags)           `thenC`
 590
 591         -- generate a heap check if necessary
 592         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 593
 594         -- and finally the code for the alternative
 595         cgExpr rhs)
 596     )
 597 \end{code}
 598
 599 %************************************************************************
 600 %*                                                                      *
 601 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 602 %*                                                                      *
 603 %************************************************************************
 604
 605 Turgid-but-non-monadic code to conjure up the required info from
 606 algebraic case alternatives for semi-tagging.
 607
 608 \begin{code}
 609 cgSemiTaggedAlts :: Id
 610                  -> [(DataCon, [Id], [Bool], StgExpr)]
 611                  -> GenStgCaseDefault Id Id
 612                  -> SemiTaggingStuff
 613
 614 cgSemiTaggedAlts binder alts deflt
 615   = Just (map st_alt alts, st_deflt deflt)
 616   where
 617     uniq        = getUnique binder
 618
 619     st_deflt StgNoDefault = Nothing
 620
 621     st_deflt (StgBindDefault _)
 622       = Just (Just binder,
 623               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 624                mkDefaultLabel uniq)
 625              )
 626
 627     st_alt (con, args, use_mask, _)
 628       =  -- Ha!  Nothing to do; Node already points to the thing
 629          (con_tag,
 630            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 631                 [mkIntCLit (length args)], -- how big the thing in the heap is
 632              join_label)
 633             )
 634       where
 635         con_tag     = dataConTag con
 636         join_label  = mkAltLabel uniq con_tag
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection[CgCase-prim-alts]{Primitive alternatives}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 646 for dealing with the alternatives of a primitive @case@, given an
 647 addressing mode for the thing to scrutinise.  It also keeps track of
 648 the maximum stack depth encountered down any branch.
 649
 650 As usual, no binders in the alternatives are yet bound.
 651
 652 \begin{code}
 653 cgPrimInlineAlts bndr tycon alts deflt
 654   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 655   where
 656         uniq = getUnique bndr
 657         kind = tyConPrimRep tycon
 658
 659 cgPrimEvalAlts bndr tycon alts deflt
 660   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 661   where
 662         reg  = WARN( case kind of { PtrRep -> True; other -> False },
 663                      text "cgPrimEE" <+> ppr bndr <+> ppr tycon  )
 664                dataReturnConvPrim kind
 665         kind = tyConPrimRep tycon
 666
 667 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 668   =     -- first bind the default if necessary
 669     bindNewPrimToAmode bndr scrutinee           `thenC`
 670     cgPrimAlts gc_flag scrutinee alts deflt regs
 671
 672 cgPrimAlts gc_flag scrutinee alts deflt regs
 673   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 674              (cgPrimDefault gc_flag regs deflt)
 675                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 676
 677     absC (CSwitch scrutinee alt_absCs deflt_absC)
 678         -- CSwitch does sensible things with one or zero alternatives
 679
 680
 681 cgPrimAlt :: GCFlag
 682           -> [MagicId]                  -- live registers
 683           -> (Literal, StgExpr)         -- The alternative
 684           -> FCode (Literal, AbstractC) -- Its compiled form
 685
 686 cgPrimAlt gc_flag regs (lit, rhs)
 687   = getAbsC rhs_code     `thenFC` \ absC ->
 688     returnFC (lit,absC)
 689   where
 690     rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
 691
 692 cgPrimDefault :: GCFlag
 693               -> [MagicId]              -- live registers
 694               -> StgCaseDefault
 695               -> FCode AbstractC
 696
 697 cgPrimDefault gc_flag regs StgNoDefault
 698   = panic "cgPrimDefault: No default in prim case"
 699
 700 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 701   = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
 702 \end{code}
 703
 704
 705 %************************************************************************
 706 %*                                                                      *
 707 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 708 %*                                                                      *
 709 %************************************************************************
 710
 711 \begin{code}
 712 saveVolatileVarsAndRegs
 713     :: StgLiveVars                    -- Vars which should be made safe
 714     -> FCode (AbstractC,              -- Assignments to do the saves
 715               EndOfBlockInfo,         -- sequel for the alts
 716               Maybe VirtualSpOffset)  -- Slot for current cost centre
 717
 718
 719 saveVolatileVarsAndRegs vars
 720   = saveVolatileVars vars       `thenFC` \ var_saves ->
 721     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 722     getEndOfBlockInfo           `thenFC` \ eob_info ->
 723     returnFC (mkAbstractCs [var_saves, cc_save],
 724               eob_info,
 725               maybe_cc_slot)
 726
 727
 728 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 729                  -> FCode AbstractC     -- Assignments to to the saves
 730
 731 saveVolatileVars vars
 732   = save_em (varSetElems vars)
 733   where
 734     save_em [] = returnFC AbsCNop
 735
 736     save_em (var:vars)
 737       = getCAddrModeIfVolatile var `thenFC` \ v ->
 738         case v of
 739             Nothing         -> save_em vars -- Non-volatile, so carry on
 740
 741
 742             Just vol_amode  ->  -- Aha! It's volatile
 743                                save_var var vol_amode   `thenFC` \ abs_c ->
 744                                save_em vars             `thenFC` \ abs_cs ->
 745                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 746
 747     save_var var vol_amode
 748       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 749         rebindToStack var slot          `thenC`
 750         getSpRelOffset slot             `thenFC` \ sp_rel ->
 751         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 752       where
 753         kind = getAmodeRep vol_amode
 754 \end{code}
 755
 756 ---------------------------------------------------------------------------
 757
 758 When we save the current cost centre (which is done for lexical
 759 scoping), we allocate a free stack location, and return (a)~the
 760 virtual offset of the location, to pass on to the alternatives, and
 761 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 762
 763 \begin{code}
 764 saveCurrentCostCentre ::
 765         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 766                AbstractC)               -- Assignment to save it
 767
 768 saveCurrentCostCentre
 769   = if not opt_SccProfilingOn then
 770         returnFC (Nothing, AbsCNop)
 771     else
 772         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 773         dataStackSlots [slot]                         `thenC`
 774         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 775         returnFC (Just slot,
 776                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 777
 778 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 779 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 780 restoreCurrentCostCentre (Just slot)
 781  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 782    freeStackSlots [slot]                         `thenC`
 783    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 784     -- we use the RESTORE_CCCS macro, rather than just
 785     -- assigning into CurCostCentre, in case RESTORE_CCCS
 786     -- has some sanity-checking in it.
 787 \end{code}
 788
 789 %************************************************************************
 790 %*                                                                      *
 791 \subsection[CgCase-return-vec]{Building a return vector}
 792 %*                                                                      *
 793 %************************************************************************
 794
 795 Build a return vector, and return a suitable label addressing
 796 mode for it.
 797
 798 \begin{code}
 799 mkReturnVector :: Unique
 800                -> [(ConTag, AbstractC)] -- Branch codes
 801                -> AbstractC             -- Default case
 802                -> SRT                   -- continuation's SRT
 803                -> Liveness              -- stack liveness
 804                -> CtrlReturnConvention
 805                -> FCode CAddrMode
 806
 807 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 808   = getSRTLabel `thenFC` \srt_label ->
 809     let
 810      (return_vec_amode, vtbl_body) = case ret_conv of {
 811
 812         -- might be a polymorphic case...
 813       UnvectoredReturn 0 ->
 814         ASSERT(null tagged_alt_absCs)
 815         (CLbl ret_label RetRep,
 816          absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
 817
 818       UnvectoredReturn n ->
 819         -- find the tag explicitly rather than using tag_reg for now.
 820         -- on architectures with lots of regs the tag will be loaded
 821         -- into tag_reg by the code doing the returning.
 822         let
 823           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 824         in
 825         (CLbl ret_label RetRep,
 826          absC (CRetDirect uniq
 827                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 828                             (srt_label, srt)
 829                             liveness));
 830
 831       VectoredReturn table_size ->
 832         let
 833           (vector_table, alts_absC) =
 834             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 835
 836           ret_vector = CRetVector vtbl_label
 837                           vector_table
 838                           (srt_label, srt) liveness
 839         in
 840         (CLbl vtbl_label DataPtrRep,
 841          -- alts come first, because we don't want to declare all the symbols
 842          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 843         )
 844
 845     } in
 846     vtbl_body                                               `thenC`
 847     returnFC return_vec_amode
 848     -- )
 849   where
 850
 851     vtbl_label = mkVecTblLabel uniq
 852     ret_label = mkReturnInfoLabel uniq
 853
 854     deflt_lbl =
 855         case nonemptyAbsC deflt_absC of
 856                  -- the simplifier might have eliminated a case
 857            Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
 858            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 859
 860     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 861     mk_vector_entry tag
 862       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 863              []     -> (deflt_lbl, AbsCNop)
 864              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 865              _      -> panic "mkReturnVector: too many"
 866 \end{code}
 867
 868 %************************************************************************
 869 %*                                                                      *
 870 \subsection[CgCase-utils]{Utilities for handling case expressions}
 871 %*                                                                      *
 872 %************************************************************************
 873
 874 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 875 heap check or not.  These heap checks are always in a case
 876 alternative, so we use altHeapCheck.
 877
 878 \begin{code}
 879 possibleHeapCheck
 880         :: GCFlag
 881         -> Bool                         --  True <=> algebraic case
 882         -> [MagicId]                    --  live registers
 883         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 884         -> Maybe Unique                 --  return address unique
 885         -> Code                         --  continuation
 886         -> Code
 887
 888 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
 889   = altHeapCheck is_alg regs tags AbsCNop lbl code
 890 possibleHeapCheck NoGC  _ _ tags lbl code
 891   = code
 892 \end{code}