ghc/compiler/codeGen/CgCase.lhs

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