ghc/compiler/codeGen/CgCase.lhs

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