ghc/compiler/codeGen/CgCase.lhs

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