ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.22 1999/01/27 14:51:31 simonpj 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, isFunTyCon, isPrimTyCon,
  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   =        -- bind the default binder (it covers all the alternatives)
 550     (if (isDeadBinder bndr)
 551         then nopC
 552         else bindNewToReg bndr node mkLFArgument)       `thenC`
 553
 554     cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
 555                 False{-not poly case-} alts deflt
 556                 False{-don't emit yield-}       `thenFC` \ (tagged_alts, deflt_c) ->
 557
 558         -- Do the switch
 559     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 560  where
 561     -- A temporary variable to hold the tag; this is unaffected by GC because
 562     -- the heap-checks in the branches occur after the switch
 563     tag_amode = CTemp uniq IntRep
 564     uniq = getUnique bndr
 565 \end{code}
 566
 567 Third (real) case: primitive result type.
 568
 569 \begin{code}
 570 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
 571   = cgPrimInlineAlts bndr ty alts deflt
 572 \end{code}
 573
 574
 575 %************************************************************************
 576 %*                                                                      *
 577 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 578 %*                                                                      *
 579 %************************************************************************
 580
 581 In @cgAlgAlts@, none of the binders in the alternatives are
 582 assumed to be yet bound.
 583
 584 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
 585 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
 586 beginning of  each alternative. Normally we  want that. The  only exception
 587 are inlined alternatives.
 588
 589 \begin{code}
 590 cgAlgAlts :: GCFlag
 591           -> Unique
 592           -> AbstractC                          -- Restore-cost-centre instruction
 593           -> Bool                               -- True <=> branches must be labelled
 594           -> Bool                               -- True <=> polymorphic case
 595           -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
 596           -> StgCaseDefault                     -- The default
 597           -> Bool                               -- Context switch at alts?
 598           -> FCode ([(ConTag, AbstractC)],      -- The branches
 599                     AbstractC                   -- The default case
 600              )
 601
 602 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
 603           emit_yield{-should a yield macro be emitted?-}
 604
 605   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 606              (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
 607 \end{code}
 608
 609 \begin{code}
 610 cgAlgDefault :: GCFlag
 611              -> Bool                    -- could be a function-typed result?
 612              -> Unique -> AbstractC -> Bool -- turgid state...
 613              -> StgCaseDefault          -- input
 614              -> Bool
 615              -> FCode AbstractC         -- output
 616
 617 cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _
 618   = returnFC AbsCNop
 619
 620 cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
 621              (StgBindDefault rhs)
 622           emit_yield{-should a yield macro be emitted?-}
 623
 624   =     -- We have arranged that Node points to the thing
 625     getAbsC (absC restore_cc `thenC`
 626              (if opt_GranMacros && emit_yield
 627                 then yield [node] False
 628                 else absC AbsCNop)                            `thenC`
 629              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 630         -- Node is live, but doesn't need to point at the thing itself;
 631         -- it's ok for Node to point to an indirection or FETCH_ME
 632         -- Hence no need to re-enter Node.
 633     )                                   `thenFC` \ abs_c ->
 634
 635     let
 636         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 637                     | otherwise         = abs_c
 638     in
 639     returnFC final_abs_c
 640   where
 641     lbl = mkDefaultLabel uniq
 642
 643 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 644
 645 cgAlgAlt :: GCFlag
 646          -> Unique -> AbstractC -> Bool         -- turgid state
 647          -> Bool                               -- Context switch at alts?
 648          -> (DataCon, [Id], [Bool], StgExpr)
 649          -> FCode (ConTag, AbstractC)
 650
 651 cgAlgAlt gc_flag uniq restore_cc must_label_branch
 652          emit_yield{-should a yield macro be emitted?-}
 653          (con, args, use_mask, rhs)
 654   = getAbsC (absC restore_cc `thenC`
 655              (if opt_GranMacros && emit_yield
 656                 then yield [node] True          -- XXX live regs wrong
 657                 else absC AbsCNop)                               `thenC`
 658              (case gc_flag of
 659                 NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
 660                 GCMayHappen -> bindConArgs con args
 661              )  `thenC`
 662              possibleHeapCheck gc_flag False [node] [] Nothing (
 663              cgExpr rhs)
 664             ) `thenFC` \ abs_c ->
 665     let
 666         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 667                     | otherwise         = abs_c
 668     in
 669     returnFC (tag, final_abs_c)
 670   where
 671     tag = dataConTag con
 672     lbl = mkAltLabel uniq tag
 673
 674 cgUnboxedTupleAlt
 675         :: CLabel                       -- label of the alternative
 676         -> AbstractC                    -- junk
 677         -> Bool                         -- ctxt switch
 678         -> (DataCon, [Id], [Bool], StgExpr) -- alternative
 679         -> FCode AbstractC
 680
 681 cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
 682   = getAbsC (
 683         absC restore_cc `thenC`
 684
 685         bindUnboxedTupleComponents args
 686                       `thenFC` \ (live_regs,tags,stack_res) ->
 687         (if opt_GranMacros && emit_yield
 688             then yield live_regs True           -- XXX live regs wrong?
 689             else absC AbsCNop)                         `thenC`
 690         let
 691               -- ToDo: could maybe use Nothing here if stack_res is False
 692               -- since the heap-check can just return to the top of the
 693               -- stack.
 694               ret_addr = Just lbl
 695         in
 696
 697         -- free up stack slots containing tags,
 698         freeStackSlots (map fst tags)           `thenC`
 699
 700         -- generate a heap check if necessary
 701         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 702
 703         -- and finally the code for the alternative
 704         cgExpr rhs)
 705     )
 706 \end{code}
 707
 708 %************************************************************************
 709 %*                                                                      *
 710 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 Turgid-but-non-monadic code to conjure up the required info from
 715 algebraic case alternatives for semi-tagging.
 716
 717 \begin{code}
 718 cgSemiTaggedAlts :: Id
 719                  -> [(DataCon, [Id], [Bool], StgExpr)]
 720                  -> GenStgCaseDefault Id Id
 721                  -> SemiTaggingStuff
 722
 723 cgSemiTaggedAlts binder alts deflt
 724   = Just (map st_alt alts, st_deflt deflt)
 725   where
 726     uniq        = getUnique binder
 727
 728     st_deflt StgNoDefault = Nothing
 729
 730     st_deflt (StgBindDefault _)
 731       = Just (Just binder,
 732               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 733                mkDefaultLabel uniq)
 734              )
 735
 736     st_alt (con, args, use_mask, _)
 737       =  -- Ha!  Nothing to do; Node already points to the thing
 738          (con_tag,
 739            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 740                 [mkIntCLit (length args)], -- how big the thing in the heap is
 741              join_label)
 742             )
 743       where
 744         con_tag     = dataConTag con
 745         join_label  = mkAltLabel uniq con_tag
 746 \end{code}
 747
 748 %************************************************************************
 749 %*                                                                      *
 750 \subsection[CgCase-prim-alts]{Primitive alternatives}
 751 %*                                                                      *
 752 %************************************************************************
 753
 754 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 755 for dealing with the alternatives of a primitive @case@, given an
 756 addressing mode for the thing to scrutinise.  It also keeps track of
 757 the maximum stack depth encountered down any branch.
 758
 759 As usual, no binders in the alternatives are yet bound.
 760
 761 \begin{code}
 762 cgPrimInlineAlts bndr ty alts deflt
 763   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 764   where
 765         uniq = getUnique bndr
 766         kind = typePrimRep ty
 767
 768 cgPrimEvalAlts bndr ty alts deflt
 769   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 770   where
 771         reg = dataReturnConvPrim kind
 772         kind = typePrimRep ty
 773
 774 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 775   =     -- first bind the default if necessary
 776     (if isDeadBinder bndr
 777         then nopC
 778         else bindNewPrimToAmode bndr scrutinee)         `thenC`
 779     cgPrimAlts gc_flag scrutinee alts deflt regs
 780
 781 cgPrimAlts gc_flag scrutinee alts deflt regs
 782   = forkAlts (map (cgPrimAlt gc_flag regs) alts)
 783              (cgPrimDefault gc_flag regs deflt)
 784                                         `thenFC` \ (alt_absCs, deflt_absC) ->
 785
 786     absC (CSwitch scrutinee alt_absCs deflt_absC)
 787         -- CSwitch does sensible things with one or zero alternatives
 788
 789
 790 cgPrimAlt :: GCFlag
 791           -> [MagicId]                  -- live registers
 792           -> (Literal, StgExpr)         -- The alternative
 793           -> FCode (Literal, AbstractC) -- Its compiled form
 794
 795 cgPrimAlt gc_flag regs (lit, rhs)
 796   = getAbsC rhs_code     `thenFC` \ absC ->
 797     returnFC (lit,absC)
 798   where
 799     rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
 800
 801 cgPrimDefault :: GCFlag
 802               -> [MagicId]              -- live registers
 803               -> StgCaseDefault
 804               -> FCode AbstractC
 805
 806 cgPrimDefault gc_flag regs StgNoDefault
 807   = panic "cgPrimDefault: No default in prim case"
 808
 809 cgPrimDefault gc_flag regs (StgBindDefault rhs)
 810   = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
 811 \end{code}
 812
 813
 814 %************************************************************************
 815 %*                                                                      *
 816 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 817 %*                                                                      *
 818 %************************************************************************
 819
 820 \begin{code}
 821 saveVolatileVarsAndRegs
 822     :: StgLiveVars                    -- Vars which should be made safe
 823     -> FCode (AbstractC,              -- Assignments to do the saves
 824               EndOfBlockInfo,         -- sequel for the alts
 825               Maybe VirtualSpOffset)  -- Slot for current cost centre
 826
 827
 828 saveVolatileVarsAndRegs vars
 829   = saveVolatileVars vars       `thenFC` \ var_saves ->
 830     saveCurrentCostCentre       `thenFC` \ (maybe_cc_slot, cc_save) ->
 831     getEndOfBlockInfo           `thenFC` \ eob_info ->
 832     returnFC (mkAbstractCs [var_saves, cc_save],
 833               eob_info,
 834               maybe_cc_slot)
 835
 836
 837 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
 838                  -> FCode AbstractC     -- Assignments to to the saves
 839
 840 saveVolatileVars vars
 841   = save_em (varSetElems vars)
 842   where
 843     save_em [] = returnFC AbsCNop
 844
 845     save_em (var:vars)
 846       = getCAddrModeIfVolatile var `thenFC` \ v ->
 847         case v of
 848             Nothing         -> save_em vars -- Non-volatile, so carry on
 849
 850
 851             Just vol_amode  ->  -- Aha! It's volatile
 852                                save_var var vol_amode   `thenFC` \ abs_c ->
 853                                save_em vars             `thenFC` \ abs_cs ->
 854                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 855
 856     save_var var vol_amode
 857       = allocPrimStack (getPrimRepSize kind)    `thenFC` \ slot ->
 858         rebindToStack var slot          `thenC`
 859         getSpRelOffset slot             `thenFC` \ sp_rel ->
 860         returnFC (CAssign (CVal sp_rel kind) vol_amode)
 861       where
 862         kind = getAmodeRep vol_amode
 863 \end{code}
 864
 865 ---------------------------------------------------------------------------
 866
 867 When we save the current cost centre (which is done for lexical
 868 scoping), we allocate a free stack location, and return (a)~the
 869 virtual offset of the location, to pass on to the alternatives, and
 870 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 871
 872 \begin{code}
 873 saveCurrentCostCentre ::
 874         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
 875                AbstractC)               -- Assignment to save it
 876
 877 saveCurrentCostCentre
 878   = if not opt_SccProfilingOn then
 879         returnFC (Nothing, AbsCNop)
 880     else
 881         allocPrimStack (getPrimRepSize CostCentreRep)  `thenFC` \ slot ->
 882         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 883         returnFC (Just slot,
 884                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 885
 886 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 887
 888 restoreCurrentCostCentre Nothing
 889  = returnFC AbsCNop
 890 restoreCurrentCostCentre (Just slot)
 891  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 892    freeStackSlots [slot]                         `thenC`
 893    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 894     -- we use the RESTORE_CCCS macro, rather than just
 895     -- assigning into CurCostCentre, in case RESTORE_CCC
 896     -- has some sanity-checking in it.
 897 \end{code}
 898
 899 %************************************************************************
 900 %*                                                                      *
 901 \subsection[CgCase-return-vec]{Building a return vector}
 902 %*                                                                      *
 903 %************************************************************************
 904
 905 Build a return vector, and return a suitable label addressing
 906 mode for it.
 907
 908 \begin{code}
 909 mkReturnVector :: Unique
 910                -> [(ConTag, AbstractC)] -- Branch codes
 911                -> AbstractC             -- Default case
 912                -> SRT                   -- continuation's SRT
 913                -> Liveness              -- stack liveness
 914                -> CtrlReturnConvention
 915                -> FCode CAddrMode
 916
 917 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 918   = getSRTLabel `thenFC` \srt_label ->
 919     let
 920      srt_info = (srt_label, srt)
 921
 922      (return_vec_amode, vtbl_body) = case ret_conv of {
 923
 924         -- might be a polymorphic case...
 925       UnvectoredReturn 0 ->
 926         ASSERT(null tagged_alt_absCs)
 927         (CLbl ret_label RetRep,
 928          absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
 929
 930       UnvectoredReturn n ->
 931         -- find the tag explicitly rather than using tag_reg for now.
 932         -- on architectures with lots of regs the tag will be loaded
 933         -- into tag_reg by the code doing the returning.
 934         let
 935           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 936         in
 937         (CLbl ret_label RetRep,
 938          absC (CRetDirect uniq
 939                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 940                             (srt_label, srt)
 941                             liveness));
 942
 943       VectoredReturn table_size ->
 944         let
 945           (vector_table, alts_absC) =
 946             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 947
 948           ret_vector = CRetVector vtbl_label
 949                           vector_table
 950                           (srt_label, srt) liveness
 951         in
 952         (CLbl vtbl_label DataPtrRep,
 953          -- alts come first, because we don't want to declare all the symbols
 954          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 955         )
 956
 957     } in
 958     vtbl_body                                               `thenC`
 959     returnFC return_vec_amode
 960     -- )
 961   where
 962
 963     vtbl_label = mkVecTblLabel uniq
 964     ret_label = mkReturnInfoLabel uniq
 965
 966     deflt_lbl =
 967         case nonemptyAbsC deflt_absC of
 968                  -- the simplifier might have eliminated a case
 969            Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
 970            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 971
 972     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 973     mk_vector_entry tag
 974       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 975              []     -> (deflt_lbl, AbsCNop)
 976              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 977              _      -> panic "mkReturnVector: too many"
 978 \end{code}
 979
 980 %************************************************************************
 981 %*                                                                      *
 982 \subsection[CgCase-utils]{Utilities for handling case expressions}
 983 %*                                                                      *
 984 %************************************************************************
 985
 986 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 987 heap check or not.  These heap checks are always in a case
 988 alternative, so we use altHeapCheck.
 989
 990 \begin{code}
 991 possibleHeapCheck
 992         :: GCFlag
 993         -> Bool                         --  True <=> algebraic case
 994         -> [MagicId]                    --  live registers
 995         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 996         -> Maybe CLabel                 --  return address
 997         -> Code                         --  continuation
 998         -> Code
 999
1000 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
1001   = altHeapCheck is_alg regs tags AbsCNop lbl code
1002 possibleHeapCheck NoGC  _ _ tags lbl code
1003   = code
1004 \end{code}
1005
1006 splitTyConAppThroughNewTypes is like splitTyConApp_maybe except
1007 that it looks through newtypes in addition to synonyms.  It's
1008 useful in the back end where we're not interested in newtypes
1009 anymore.
1010
1011 Sometimes, we've thrown away the constructors during pruning in the
1012 renamer.  In these cases, we emit a warning and fall back to using a
1013 SEQ_FRAME to evaluate the case scrutinee.
1014
1015 \begin{code}
1016 getScrutineeTyCon :: Type -> Maybe TyCon
1017 getScrutineeTyCon ty =
1018    case (splitTyConAppThroughNewTypes ty) of
1019         Nothing -> Nothing
1020         Just (tc,_) ->
1021                 if isFunTyCon tc  then Nothing else     -- not interested in funs
1022                 if isPrimTyCon tc then Just tc else     -- return primitive tycons
1023                         -- otherwise (algebraic tycons) check the no. of constructors
1024                 case (tyConFamilySize tc) of
1025                         0 -> pprTrace "Warning" (hcat [
1026                                 text "constructors for ",
1027                                 ppr tc,
1028                                 text " not available.\n\tUse -fno-prune-tydecls to fix."
1029                                 ]) Nothing
1030                         _ -> Just tc
1031
1032 splitTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
1033 splitTyConAppThroughNewTypes ty
1034   = case splitTyConApp_maybe ty of
1035       Just (tc, tys)
1036         | isNewTyCon tc ->  splitTyConAppThroughNewTypes ty
1037         | otherwise     ->  Just (tc, tys)
1038         where
1039           ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys)
1040
1041       other  -> Nothing
1042
1043 \end{code}