ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 simonpj 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,
  31                           rebindToStack, getCAddrMode,
  32                           getCAddrModeAndInfo, getCAddrModeIfVolatile,
  33                           buildContLivenessMask, nukeDeadBindings,
  34                         )
  35 import CgCon            ( bindConArgs, bindUnboxedTupleComponents )
  36 import CgHeapery        ( altHeapCheck )
  37 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg,
  38                           CtrlReturnConvention(..)
  39                         )
  40 import CgStackery       ( allocPrimStack, allocStackTop,
  41                           deAllocStackTop, freeStackSlots, dataStackSlots
  42                         )
  43 import CgTailCall       ( tailCallFun )
  44 import CgUsages         ( getSpRelOffset )
  45 import CLabel           ( mkVecTblLabel, mkClosureTblLabel,
  46                           mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
  47                         )
  48 import ClosureInfo      ( mkLFArgument )
  49 import CmdLineOpts      ( opt_SccProfilingOn )
  50 import Id               ( Id, idPrimRep, isDeadBinder )
  51 import DataCon          ( DataCon, dataConTag, fIRST_TAG, ConTag,
  52                           isUnboxedTupleCon )
  53 import VarSet           ( varSetElems )
  54 import Literal          ( Literal )
  55 import PrimOp           ( primOpOutOfLine, PrimOp(..) )
  56 import PrimRep          ( getPrimRepSize, retPrimRepSize, PrimRep(..)
  57                         )
  58 import TyCon            ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
  59                           isFunTyCon, isPrimTyCon,
  60                         )
  61 import Type             ( Type, typePrimRep, splitAlgTyConApp,
  62                           splitTyConApp_maybe, repType )
  63 import Unique           ( Unique, Uniquable(..), newTagUnique )
  64 import Maybes           ( maybeToBool )
  65 import Util
  66 import Outputable
  67 \end{code}
  68
  69 \begin{code}
  70 data GCFlag
  71   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  72                 -- tidy before the code for the scrutinee.
  73
  74   | NoGC        -- The scrutinee is a primitive value, or a call to a
  75                 -- primitive op which does no GC.  Hence the case can
  76                 -- be done inline, without tidying up first.
  77 \end{code}
  78
  79 It is quite interesting to decide whether to put a heap-check
  80 at the start of each alternative.  Of course we certainly have
  81 to do so if the case forces an evaluation, or if there is a primitive
  82 op which can trigger GC.
  83
  84 A more interesting situation is this:
  85
  86  \begin{verbatim}
  87         !A!;
  88         ...A...
  89         case x# of
  90           0#      -> !B!; ...B...
  91           default -> !C!; ...C...
  92  \end{verbatim}
  93
  94 where \tr{!x!} indicates a possible heap-check point. The heap checks
  95 in the alternatives {\em can} be omitted, in which case the topmost
  96 heapcheck will take their worst case into account.
  97
  98 In favour of omitting \tr{!B!}, \tr{!C!}:
  99
 100  - {\em May} save a heap overflow test,
 101         if ...A... allocates anything.  The other advantage
 102         of this is that we can use relative addressing
 103         from a single Hp to get at all the closures so allocated.
 104
 105  - No need to save volatile vars etc across the case
 106
 107 Against:
 108
 109   - May do more allocation than reqd.  This sometimes bites us
 110         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 111         worst-casing is done, because many many calls to nfib are leaf calls
 112         which don't need to allocate anything.
 113
 114         This never hurts us if there is only one alternative.
 115
 116 \begin{code}
 117 cgCase  :: StgExpr
 118         -> StgLiveVars
 119         -> StgLiveVars
 120         -> Id
 121         -> SRT
 122         -> StgCaseAlts
 123         -> Code
 124 \end{code}
 125
 126 Special case #1:  PrimOps returning enumeration types.
 127
 128 For enumeration types, we invent a temporary (builtin-unique 1) to
 129 hold the tag, and cross our fingers that this doesn't clash with
 130 anything else.  Builtin-unique 0 is used for a similar reason when
 131 compiling enumerated-type primops in CgExpr.lhs.  We can't use the
 132 unique from the case binder, because this is used to hold the actual
 133 closure (when the case binder is live, that is).
 134
 135 There is an extra special case for
 136
 137         case tagToEnum# x of
 138                 ...
 139
 140 which generates no code for the primop, unless x is used in the
 141 alternatives (in which case we lookup the tag in the relevant closure
 142 table to get the closure).
 143
 144 Being a bit short of uniques for temporary variables here, we use
 145 newTagUnique to generate a new unique from the case binder.  The case
 146 binder's unique will presumably have the 'c' tag (generated by
 147 CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
 148 doesn't clash with anything else.
 149
 150 \begin{code}
 151 cgCase (StgPrimApp op args res_ty)
 152          live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
 153   | isEnumerationTyCon tycon
 154   = getArgAmodes args `thenFC` \ arg_amodes ->
 155
 156     let tag_amode = case op of
 157                         TagToEnumOp -> only arg_amodes
 158                         _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
 159
 160         closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
 161     in
 162
 163     case op of {
 164         TagToEnumOp -> nopC;  -- no code!
 165
 166         _ ->    -- Perform the operation
 167                getVolatileRegs live_in_alts     `thenFC` \ vol_regs ->
 168
 169                absC (COpStmt [tag_amode] op
 170                  arg_amodes -- note: no liveness arg
 171                  vol_regs)
 172     }                                           `thenC`
 173
 174         -- bind the default binder if necessary
 175         -- The deadness info is set by StgVarInfo
 176     (if (isDeadBinder bndr)
 177         then nopC
 178         else bindNewToTemp bndr                 `thenFC` \ bndr_amode ->
 179              absC (CAssign bndr_amode closure))
 180                                                 `thenC`
 181
 182         -- compile the alts
 183     cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
 184                 False{-not poly case-} alts deflt
 185                 False{-don't emit yield-}       `thenFC` \ (tagged_alts, deflt_c) ->
 186
 187         -- Do the switch
 188     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 189
 190    where
 191         (Just (tycon,_)) = splitTyConApp_maybe res_ty
 192         uniq = getUnique bndr
 193 \end{code}
 194
 195 Special case #2: inline PrimOps.
 196
 197 \begin{code}
 198 cgCase (StgPrimApp op args res_ty)
 199         live_in_whole_case live_in_alts bndr srt alts
 200   | not (primOpOutOfLine op)
 201   =
 202         -- Get amodes for the arguments and results
 203     getArgAmodes args                   `thenFC` \ arg_amodes ->
 204     let
 205         result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
 206     in
 207         -- Perform the operation
 208     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 209
 210     absC (COpStmt result_amodes op
 211                  arg_amodes -- note: no liveness arg
 212                  vol_regs)              `thenC`
 213
 214         -- Scrutinise the result
 215     cgInlineAlts bndr alts
 216 \end{code}
 217
 218 TODO: Case-of-case of primop can probably be done inline too (but
 219 maybe better to translate it out beforehand).  See
 220 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
 221 4.02).
 222
 223 Another special case: scrutinising a primitive-typed variable.  No
 224 evaluation required.  We don't save volatile variables, nor do we do a
 225 heap-check in the alternatives.  Instead, the heap usage of the
 226 alternatives is worst-cased and passed upstream.  This can result in
 227 allocating more heap than strictly necessary, but it will sometimes
 228 eliminate a heap check altogether.
 229
 230 \begin{code}
 231 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 232                         (StgPrimAlts ty alts deflt)
 233
 234   =
 235     getCAddrMode v              `thenFC` \amode ->
 236
 237     {-
 238        Careful! we can't just bind the default binder to the same thing
 239        as the scrutinee, since it might be a stack location, and having
 240        two bindings pointing at the same stack locn doesn't work (it
 241        confuses nukeDeadBindings).  Hence, use a new temp.
 242     -}
 243     bindNewToTemp bndr                  `thenFC`  \deflt_amode ->
 244     absC (CAssign deflt_amode amode)    `thenC`
 245
 246     cgPrimAlts NoGC amode alts deflt []
 247 \end{code}
 248
 249 Special case: scrutinising a non-primitive variable.
 250 This can be done a little better than the general case, because
 251 we can reuse/trim the stack slot holding the variable (if it is in one).
 252
 253 \begin{code}
 254 cgCase (StgApp fun args)
 255         live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
 256   =
 257     getCAddrModeAndInfo fun             `thenFC` \ (fun_amode, lf_info) ->
 258     getArgAmodes args                   `thenFC` \ arg_amodes ->
 259
 260         -- Squish the environment
 261     nukeDeadBindings live_in_alts       `thenC`
 262     saveVolatileVarsAndRegs live_in_alts
 263                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 264
 265     allocStackTop retPrimRepSize        `thenFC` \_ ->
 266
 267     forkEval alts_eob_info nopC (
 268                 deAllocStackTop retPrimRepSize `thenFC` \_ ->
 269                 cgEvalAlts maybe_cc_slot bndr srt alts)
 270                                          `thenFC` \ scrut_eob_info ->
 271
 272     let real_scrut_eob_info =
 273                 if not_con_ty
 274                         then reserveSeqFrame scrut_eob_info
 275                         else scrut_eob_info
 276     in
 277
 278     setEndOfBlockInfo real_scrut_eob_info (
 279       tailCallFun fun fun_amode lf_info arg_amodes save_assts
 280       )
 281
 282   where
 283      not_con_ty = case (getScrutineeTyCon ty) of
 284                         Just _ -> False
 285                         other  -> True
 286 \end{code}
 287
 288 Note about return addresses: we *always* push a return address, even
 289 if because of an optimisation we end up jumping direct to the return
 290 code (not through the address itself).  The alternatives always assume
 291 that the return address is on the stack.  The return address is
 292 required in case the alternative performs a heap check, since it
 293 encodes the liveness of the slots in the activation record.
 294
 295 On entry to the case alternative, we can re-use the slot containing
 296 the return address immediately after the heap check.  That's what the
 297 deAllocStackTop call is doing above.
 298
 299 Finally, here is the general case.
 300
 301 \begin{code}
 302 cgCase expr live_in_whole_case live_in_alts bndr srt alts
 303   =     -- Figure out what volatile variables to save
 304     nukeDeadBindings live_in_whole_case `thenC`
 305
 306     saveVolatileVarsAndRegs live_in_alts
 307                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 308
 309     -- Save those variables right now!
 310     absC save_assts                     `thenC`
 311
 312     -- generate code for the alts
 313     forkEval alts_eob_info
 314         (
 315          nukeDeadBindings live_in_alts `thenC`
 316          allocStackTop retPrimRepSize   -- space for retn address
 317          `thenFC` \_ -> nopC
 318          )
 319         (deAllocStackTop retPrimRepSize `thenFC` \_ ->
 320          cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
 321
 322     let real_scrut_eob_info =
 323                 if not_con_ty
 324                         then reserveSeqFrame scrut_eob_info
 325                         else scrut_eob_info
 326     in
 327
 328     setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
 329
 330   where
 331      not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
 332                         Just _ -> False
 333                         other  -> True
 334 \end{code}
 335
 336 There's a lot of machinery going on behind the scenes to manage the
 337 stack pointer here.  forkEval takes the virtual Sp and free list from
 338 the first argument, and turns that into the *real* Sp for the second
 339 argument.  It also uses this virtual Sp as the args-Sp in the EOB info
 340 returned, so that the scrutinee will trim the real Sp back to the
 341 right place before doing whatever it does.
 342   --SDM (who just spent an hour figuring this out, and didn't want to
 343          forget it).
 344
 345 Why don't we push the return address just before evaluating the
 346 scrutinee?  Because the slot reserved for the return address might
 347 contain something useful, so we wait until performing a tail call or
 348 return before pushing the return address (see
 349 CgTailCall.pushReturnAddress).
 350
 351 This also means that the environment doesn't need to know about the
 352 free stack slot for the return address (for generating bitmaps),
 353 because we don't reserve it until just before the eval.
 354
 355 TODO!!  Problem: however, we have to save the current cost centre
 356 stack somewhere, because at the eval point the current CCS might be
 357 different.  So we pick a free stack slot and save CCCS in it.  The
 358 problem with this is that this slot isn't recorded as free/unboxed in
 359 the environment, so a case expression in the scrutinee will have the
 360 wrong bitmap attached.  Fortunately we don't ever seem to see
 361 case-of-case at the back end.  One solution might be to shift the
 362 saved CCS to the correct place in the activation record just before
 363 the jump.
 364         --SDM
 365
 366 (one consequence of the above is that activation records on the stack
 367 don't follow the layout of closures when we're profiling.  The CCS
 368 could be anywhere within the record).
 369
 370 \begin{code}
 371 alts_ty (StgAlgAlts ty _ _) = ty
 372 alts_ty (StgPrimAlts ty _ _) = ty
 373 \end{code}
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection[CgCase-primops]{Primitive applications}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 Get result amodes for a primitive operation, in the case wher GC can't happen.
 382 The  amodes are returned in canonical order, ready for the prim-op!
 383
 384         Alg case: temporaries named as in the alternatives,
 385                   plus (CTemp u) for the tag (if needed)
 386         Prim case: (CTemp u)
 387
 388 This is all disgusting, because these amodes must be consistent with those
 389 invented by CgAlgAlts.
 390
 391 \begin{code}
 392 getPrimAppResultAmodes
 393         :: Unique
 394         -> StgCaseAlts
 395         -> [CAddrMode]
 396
 397 getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
 398
 399   | isUnboxedTupleTyCon tycon =
 400         case alts of
 401             [(con, args, use_mask, rhs)] ->
 402                 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
 403             _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
 404
 405   | otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty)
 406
 407   where (tycon, _, _) = splitAlgTyConApp ty
 408
 409 -- The situation is simpler for primitive results, because there is only
 410 -- one!
 411
 412 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
 413   = [CTemp uniq (typePrimRep ty)]
 414 \end{code}
 415
 416
 417 %************************************************************************
 418 %*                                                                      *
 419 \subsection[CgCase-alts]{Alternatives}
 420 %*                                                                      *
 421 %************************************************************************
 422
 423 @cgEvalAlts@ returns an addressing mode for a continuation for the
 424 alternatives of a @case@, used in a context when there
 425 is some evaluation to be done.
 426
 427 \begin{code}
 428 cgEvalAlts :: Maybe VirtualSpOffset     -- Offset of cost-centre to be restored, if any
 429            -> Id
 430            -> SRT                       -- SRT for the continuation
 431            -> StgCaseAlts
 432            -> FCode Sequel      -- Any addr modes inside are guaranteed
 433                                 -- to be a label so that we can duplicate it
 434                                 -- without risk of duplicating code
 435
 436 cgEvalAlts cc_slot bndr srt alts
 437   =
 438     let uniq = getUnique bndr in
 439
 440     buildContLivenessMask uniq          `thenFC` \ liveness_mask ->
 441
 442     case alts of
 443
 444       -- algebraic alts ...
 445       (StgAlgAlts ty alts deflt) ->
 446
 447            -- bind the default binder (it covers all the alternatives)
 448         bindNewToReg bndr node mkLFArgument      `thenC`
 449
 450         -- Generate sequel info for use downstream
 451         -- At the moment, we only do it if the type is vector-returnable.
 452         -- Reason: if not, then it costs extra to label the
 453         -- alternatives, because we'd get return code like:
 454         --
 455         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 456         --
 457         -- which is worse than having the alt code in the switch statement
 458
 459         let     tycon_info      = getScrutineeTyCon ty
 460                 is_alg          = maybeToBool tycon_info
 461                 Just spec_tycon = tycon_info
 462         in
 463
 464         -- deal with the unboxed tuple case
 465         if is_alg && isUnboxedTupleTyCon spec_tycon then
 466             case alts of
 467                 [alt] -> let lbl = mkReturnInfoLabel uniq in
 468                          cgUnboxedTupleAlt uniq cc_slot True alt
 469                                 `thenFC` \ abs_c ->
 470                          getSRTLabel `thenFC` \srt_label ->
 471                          absC (CRetDirect uniq abs_c (srt_label, srt)
 472                                         liveness_mask) `thenC`
 473                         returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 474                 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
 475
 476         -- normal algebraic (or polymorphic) case alternatives
 477         else let
 478                 ret_conv | is_alg    = ctrlReturnConvAlg spec_tycon
 479                          | otherwise = UnvectoredReturn 0
 480
 481                 use_labelled_alts = case ret_conv of
 482                                         VectoredReturn _ -> True
 483                                         _                -> False
 484
 485                 semi_tagged_stuff
 486                    = if use_labelled_alts then
 487                         cgSemiTaggedAlts bndr alts deflt -- Just <something>
 488                      else
 489                         Nothing -- no semi-tagging info
 490
 491         in
 492         cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
 493                 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 494
 495         mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
 496                 ret_conv  `thenFC` \ return_vec ->
 497
 498         returnFC (CaseAlts return_vec semi_tagged_stuff)
 499
 500       -- primitive alts...
 501       (StgPrimAlts ty alts deflt) ->
 502
 503         -- Restore the cost centre
 504         restoreCurrentCostCentre cc_slot        `thenFC` \ cc_restore ->
 505
 506         -- Generate the switch
 507         getAbsC (cgPrimEvalAlts bndr ty alts deflt)     `thenFC` \ abs_c ->
 508
 509         -- Generate the labelled block, starting with restore-cost-centre
 510         getSRTLabel                                     `thenFC` \srt_label ->
 511         absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
 512                         (srt_label,srt) liveness_mask)  `thenC`
 513
 514         -- Return an amode for the block
 515         returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 516 \end{code}
 517
 518
 519 \begin{code}
 520 cgInlineAlts :: Id
 521              -> StgCaseAlts
 522              -> Code
 523 \end{code}
 524
 525 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 526 we  do  an inlining of the  case  no separate  functions  for returning are
 527 created, so we don't have to generate a GRAN_YIELD in that case.  This info
 528 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 529 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 530
 531 First case: primitive op returns an unboxed tuple.
 532
 533 \begin{code}
 534 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
 535   | isUnboxedTupleCon con
 536   = -- no heap check, no yield, just get in there and do it.
 537     mapFCs bindNewToTemp args `thenFC` \ _ ->
 538     cgExpr rhs
 539
 540   | otherwise
 541   = panic "cgInlineAlts: single alternative, not an unboxed tuple"
 542 \end{code}
 543
 544 Third (real) case: primitive result type.
 545
 546 \begin{code}
 547 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
 548   = cgPrimInlineAlts bndr ty alts deflt
 549 \end{code}
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 In @cgAlgAlts@, none of the binders in the alternatives are
 558 assumed to be yet bound.
 559
 560 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 561 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 562 beginning of  each alternative. Normally we  want that. The  only exception
 563 are inlined alternatives.
 564
 565 \begin{code}
 566 cgAlgAlts :: GCFlag
 567           -> Unique
 568           -> Maybe VirtualSpOffset
 569           -> Bool                               -- True <=> branches must be labelled
 570           -> Bool                               -- True <=> polymorphic case
 571           -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
 572           -> StgCaseDefault                     -- The default
 573           -> Bool                               -- Context switch at alts?
 574           -> FCode ([(ConTag, AbstractC)],      -- The branches
 575                     AbstractC                   -- The default case
 576              )
 577
 578 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
 579           emit_yield{-should a yield macro be emitted?-}
 580
 581   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 582              (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
 583 \end{code}
 584
 585 \begin{code}
 586 cgAlgDefault :: GCFlag
 587              -> Bool                    -- could be a function-typed result?
 588              -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
 589              -> StgCaseDefault          -- input
 590              -> Bool
 591              -> FCode AbstractC         -- output
 592
 593 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
 594   = returnFC AbsCNop
 595
 596 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
 597              (StgBindDefault rhs)
 598           emit_yield{-should a yield macro be emitted?-}
 599
 600   =     -- We have arranged that Node points to the thing
 601     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 602     getAbsC (absC restore_cc `thenC`
 603              -- HWL: maybe need yield here
 604              --(if emit_yield
 605              --   then yield [node] True
 606              --   else absC AbsCNop)                            `thenC`
 607              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 608         -- Node is live, but doesn't need to point at the thing itself;
 609         -- it's ok for Node to point to an indirection or FETCH_ME
 610         -- Hence no need to re-enter Node.
 611     )                                   `thenFC` \ abs_c ->
 612
 613     let
 614         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 615                     | otherwise         = abs_c
 616     in
 617     returnFC final_abs_c
 618   where
 619     lbl = mkDefaultLabel uniq
 620
 621 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 622
 623 cgAlgAlt :: GCFlag
 624          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 625          -> Bool                               -- Context switch at alts?
 626          -> (DataCon, [Id], [Bool], StgExpr)
 627          -> FCode (ConTag, AbstractC)
 628
 629 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 630          emit_yield{-should a yield macro be emitted?-}
 631          (con, args, use_mask, rhs)
 632   =
 633     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 634     getAbsC (absC restore_cc `thenC`
 635              -- HWL: maybe need yield here
 636              -- (if emit_yield
 637              --    then yield [node] True               -- XXX live regs wrong
 638              --    else absC AbsCNop)                               `thenC`
 639              (case gc_flag of
 640                 NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
 641                 GCMayHappen -> bindConArgs con args
 642              )  `thenC`
 643              possibleHeapCheck gc_flag False [node] [] Nothing (
 644              cgExpr rhs)
 645             ) `thenFC` \ abs_c ->
 646     let
 647         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 648                     | otherwise         = abs_c
 649     in
 650     returnFC (tag, final_abs_c)
 651   where
 652     tag = dataConTag con
 653     lbl = mkAltLabel uniq tag
 654
 655 cgUnboxedTupleAlt
 656         :: Unique                       -- unique for label of the alternative
 657         -> Maybe VirtualSpOffset        -- Restore cost centre
 658         -> Bool                         -- ctxt switch
 659         -> (DataCon, [Id], [Bool], StgExpr) -- alternative
 660         -> FCode AbstractC
 661
 662 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
 663   = getAbsC (
 664         bindUnboxedTupleComponents args
 665                       `thenFC` \ (live_regs,tags,stack_res) ->
 666
 667         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 668         absC restore_cc `thenC`
 669
 670         -- HWL: maybe need yield here
 671         -- (if emit_yield
 672         --    then yield live_regs True         -- XXX live regs wrong?
 673         --    else absC AbsCNop)                         `thenC`
 674         let
 675               -- ToDo: could maybe use Nothing here if stack_res is False
 676               -- since the heap-check can just return to the top of the
 677               -- stack.
 678               ret_addr = Just lbl
 679         in
 680
 681         -- free up stack slots containing tags,
 682         freeStackSlots (map fst tags)           `thenC`
 683
 684         -- generate a heap check if necessary
 685         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 686
 687         -- and finally the code for the alternative
 688         cgExpr rhs)
 689     )
 690 \end{code}
 691
 692 %************************************************************************
 693 %*                                                                      *
 694 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 695 %*                                                                      *
 696 %************************************************************************
 697
 698 Turgid-but-non-monadic code to conjure up the required info from
 699 algebraic case alternatives for semi-tagging.
 700
 701 \begin{code}
 702 cgSemiTaggedAlts :: Id
 703                  -> [(DataCon, [Id], [Bool], StgExpr)]
 704                  -> GenStgCaseDefault Id Id
 705                  -> SemiTaggingStuff
 706
 707 cgSemiTaggedAlts binder alts deflt
 708   = Just (map st_alt alts, st_deflt deflt)
 709   where
 710     uniq        = getUnique binder
 711
 712     st_deflt StgNoDefault = Nothing
 713
 714     st_deflt (StgBindDefault _)
 715       = Just (Just binder,
 716               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 717                mkDefaultLabel uniq)
 718              )
 719
 720     st_alt (con, args, use_mask, _)
 721       =  -- Ha!  Nothing to do; Node already points to the thing
 722          (con_tag,
 723            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 724                 [mkIntCLit (length args)], -- how big the thing in the heap is
 725              join_label)
 726             )
 727       where
 728         con_tag     = dataConTag con
 729         join_label  = mkAltLabel uniq con_tag
 730 \end{code}
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection[CgCase-prim-alts]{Primitive alternatives}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 739 for dealing with the alternatives of a primitive @case@, given an
 740 addressing mode for the thing to scrutinise.  It also keeps track of
 741 the maximum stack depth encountered down any branch.
 742
 743 As usual, no binders in the alternatives are yet bound.
 744
 745 \begin{code}
 746 cgPrimInlineAlts bndr ty alts deflt
 747   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 748   where
 749         uniq = getUnique bndr
 750         kind = typePrimRep ty
 751
 752 cgPrimEvalAlts bndr ty alts deflt
 753   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 754   where
 755         reg  = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty  )
 756                dataReturnConvPrim kind
 757         kind = typePrimRep ty
 758
 759 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 760   =     -- first bind the default if necessary
 761     bindNewPrimToAmode bndr scrutinee           `thenC`
 762     cgPrimAlts gc_flag scrutinee alts deflt regs
 763
 764 cgPrimAlts gc_flag scrutinee alts deflt regs
 765   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 766              (cgPrimDefault gc_flag regs deflt)
 767                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 768
 769     absC (CSwitch scrutinee alt_absCs deflt_absC)
 770         -- CSwitch does sensible things with one or zero alternatives
 771
 772
 773 cgPrimAlt :: GCFlag
 774           -> [MagicId]                  -- live registers
 775           -> (Literal, StgExpr)         -- The alternative
 776           -> FCode (Literal, AbstractC) -- Its compiled form
 777
 778 cgPrimAlt gc_flag regs (lit, rhs)
 779   = getAbsC rhs_code     `thenFC` \ absC ->
 780     returnFC (lit,absC)
 781   where
 782     rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
 783
 784 cgPrimDefault :: GCFlag
 785               -> [MagicId]              -- live registers
 786               -> StgCaseDefault
 787               -> FCode AbstractC
 788
 789 cgPrimDefault gc_flag regs StgNoDefault
 790   = panic "cgPrimDefault: No default in prim case"
 791
 792 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 793   = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
 794 \end{code}
 795
 796
 797 %************************************************************************
 798 %*                                                                      *
 799 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 800 %*                                                                      *
 801 %************************************************************************
 802
 803 \begin{code}
 804 saveVolatileVarsAndRegs
 805     :: StgLiveVars                    -- Vars which should be made safe
 806     -> FCode (AbstractC,              -- Assignments to do the saves
 807               EndOfBlockInfo,         -- sequel for the alts
 808               Maybe VirtualSpOffset)  -- Slot for current cost centre
 809
 810
 811 saveVolatileVarsAndRegs vars
 812   = saveVolatileVars vars       `thenFC` \ var_saves ->
 813     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 814     getEndOfBlockInfo           `thenFC` \ eob_info ->
 815     returnFC (mkAbstractCs [var_saves, cc_save],
 816               eob_info,
 817               maybe_cc_slot)
 818
 819
 820 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 821                  -> FCode AbstractC     -- Assignments to to the saves
 822
 823 saveVolatileVars vars
 824   = save_em (varSetElems vars)
 825   where
 826     save_em [] = returnFC AbsCNop
 827
 828     save_em (var:vars)
 829       = getCAddrModeIfVolatile var `thenFC` \ v ->
 830         case v of
 831             Nothing         -> save_em vars -- Non-volatile, so carry on
 832
 833
 834             Just vol_amode  ->  -- Aha! It's volatile
 835                                save_var var vol_amode   `thenFC` \ abs_c ->
 836                                save_em vars             `thenFC` \ abs_cs ->
 837                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 838
 839     save_var var vol_amode
 840       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 841         rebindToStack var slot          `thenC`
 842         getSpRelOffset slot             `thenFC` \ sp_rel ->
 843         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 844       where
 845         kind = getAmodeRep vol_amode
 846 \end{code}
 847
 848 ---------------------------------------------------------------------------
 849
 850 When we save the current cost centre (which is done for lexical
 851 scoping), we allocate a free stack location, and return (a)~the
 852 virtual offset of the location, to pass on to the alternatives, and
 853 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 854
 855 \begin{code}
 856 saveCurrentCostCentre ::
 857         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 858                AbstractC)               -- Assignment to save it
 859
 860 saveCurrentCostCentre
 861   = if not opt_SccProfilingOn then
 862         returnFC (Nothing, AbsCNop)
 863     else
 864         allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
 865         dataStackSlots [slot]                         `thenC`
 866         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 867         returnFC (Just slot,
 868                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 869
 870 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 871 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 872 restoreCurrentCostCentre (Just slot)
 873  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 874    freeStackSlots [slot]                         `thenC`
 875    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 876     -- we use the RESTORE_CCCS macro, rather than just
 877     -- assigning into CurCostCentre, in case RESTORE_CCCS
 878     -- has some sanity-checking in it.
 879 \end{code}
 880
 881 %************************************************************************
 882 %*                                                                      *
 883 \subsection[CgCase-return-vec]{Building a return vector}
 884 %*                                                                      *
 885 %************************************************************************
 886
 887 Build a return vector, and return a suitable label addressing
 888 mode for it.
 889
 890 \begin{code}
 891 mkReturnVector :: Unique
 892                -> [(ConTag, AbstractC)] -- Branch codes
 893                -> AbstractC             -- Default case
 894                -> SRT                   -- continuation's SRT
 895                -> Liveness              -- stack liveness
 896                -> CtrlReturnConvention
 897                -> FCode CAddrMode
 898
 899 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 900   = getSRTLabel `thenFC` \srt_label ->
 901     let
 902      (return_vec_amode, vtbl_body) = case ret_conv of {
 903
 904         -- might be a polymorphic case...
 905       UnvectoredReturn 0 ->
 906         ASSERT(null tagged_alt_absCs)
 907         (CLbl ret_label RetRep,
 908          absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
 909
 910       UnvectoredReturn n ->
 911         -- find the tag explicitly rather than using tag_reg for now.
 912         -- on architectures with lots of regs the tag will be loaded
 913         -- into tag_reg by the code doing the returning.
 914         let
 915           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 916         in
 917         (CLbl ret_label RetRep,
 918          absC (CRetDirect uniq
 919                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 920                             (srt_label, srt)
 921                             liveness));
 922
 923       VectoredReturn table_size ->
 924         let
 925           (vector_table, alts_absC) =
 926             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 927
 928           ret_vector = CRetVector vtbl_label
 929                           vector_table
 930                           (srt_label, srt) liveness
 931         in
 932         (CLbl vtbl_label DataPtrRep,
 933          -- alts come first, because we don't want to declare all the symbols
 934          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 935         )
 936
 937     } in
 938     vtbl_body                                               `thenC`
 939     returnFC return_vec_amode
 940     -- )
 941   where
 942
 943     vtbl_label = mkVecTblLabel uniq
 944     ret_label = mkReturnInfoLabel uniq
 945
 946     deflt_lbl =
 947         case nonemptyAbsC deflt_absC of
 948                  -- the simplifier might have eliminated a case
 949            Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
 950            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 951
 952     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 953     mk_vector_entry tag
 954       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 955              []     -> (deflt_lbl, AbsCNop)
 956              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 957              _      -> panic "mkReturnVector: too many"
 958 \end{code}
 959
 960 %************************************************************************
 961 %*                                                                      *
 962 \subsection[CgCase-utils]{Utilities for handling case expressions}
 963 %*                                                                      *
 964 %************************************************************************
 965
 966 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 967 heap check or not.  These heap checks are always in a case
 968 alternative, so we use altHeapCheck.
 969
 970 \begin{code}
 971 possibleHeapCheck
 972         :: GCFlag
 973         -> Bool                         --  True <=> algebraic case
 974         -> [MagicId]                    --  live registers
 975         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 976         -> Maybe Unique                 --  return address unique
 977         -> Code                         --  continuation
 978         -> Code
 979
 980 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
 981   = altHeapCheck is_alg regs tags AbsCNop lbl code
 982 possibleHeapCheck NoGC  _ _ tags lbl code
 983   = code
 984 \end{code}
 985
 986 \begin{code}
 987 getScrutineeTyCon :: Type -> Maybe TyCon
 988 getScrutineeTyCon ty =
 989    case splitTyConApp_maybe (repType ty) of
 990         Nothing -> Nothing
 991         Just (tc,_) ->
 992                 if isFunTyCon tc  then Nothing else     -- not interested in funs
 993                 if isPrimTyCon tc then Just tc else     -- return primitive tycons
 994                         -- otherwise (algebraic tycons) check the no. of constructors
 995                 Just tc
 996 \end{code}