ghc/compiler/codeGen/CgCase.lhs

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