ghc/compiler/codeGen/CgCase.lhs

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