ghc/compiler/codeGen/CgCase.lhs

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