ghc/compiler/codeGen/CgCase.lhs

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