ghc/compiler/codeGen/CgCase.lhs

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