ghc/compiler/codeGen/CgCase.lhs

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