ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgCase.lhs,v 1.40 2000/03/27 16:22:09 simonpj 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 Id               ( Id, idPrimRep, isDeadBinder )
  53 import DataCon          ( DataCon, dataConTag, fIRST_TAG, ConTag,
  54                           isUnboxedTupleCon )
  55 import VarSet           ( varSetElems )
  56 import Literal          ( Literal )
  57 import PrimOp           ( primOpOutOfLine, PrimOp(..) )
  58 import PrimRep          ( getPrimRepSize, retPrimRepSize, PrimRep(..)
  59                         )
  60 import TyCon            ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
  61                           isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
  62                           tyConDataCons, tyConFamilySize )
  63 import Type             ( Type, typePrimRep, splitAlgTyConApp,
  64                           splitTyConApp_maybe, repType )
  65 import Unique           ( Unique, Uniquable(..), mkPseudoUnique1 )
  66 import Maybes           ( maybeToBool )
  67 import Util
  68 import Outputable
  69 \end{code}
  70
  71 \begin{code}
  72 data GCFlag
  73   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  74                 -- tidy before the code for the scrutinee.
  75
  76   | NoGC        -- The scrutinee is a primitive value, or a call to a
  77                 -- primitive op which does no GC.  Hence the case can
  78                 -- be done inline, without tidying up first.
  79 \end{code}
  80
  81 It is quite interesting to decide whether to put a heap-check
  82 at the start of each alternative.  Of course we certainly have
  83 to do so if the case forces an evaluation, or if there is a primitive
  84 op which can trigger GC.
  85
  86 A more interesting situation is this:
  87
  88  \begin{verbatim}
  89         !A!;
  90         ...A...
  91         case x# of
  92           0#      -> !B!; ...B...
  93           default -> !C!; ...C...
  94  \end{verbatim}
  95
  96 where \tr{!x!} indicates a possible heap-check point. The heap checks
  97 in the alternatives {\em can} be omitted, in which case the topmost
  98 heapcheck will take their worst case into account.
  99
 100 In favour of omitting \tr{!B!}, \tr{!C!}:
 101
 102  - {\em May} save a heap overflow test,
 103         if ...A... allocates anything.  The other advantage
 104         of this is that we can use relative addressing
 105         from a single Hp to get at all the closures so allocated.
 106
 107  - No need to save volatile vars etc across the case
 108
 109 Against:
 110
 111   - May do more allocation than reqd.  This sometimes bites us
 112         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 113         worst-casing is done, because many many calls to nfib are leaf calls
 114         which don't need to allocate anything.
 115
 116         This never hurts us if there is only one alternative.
 117
 118 \begin{code}
 119 cgCase  :: StgExpr
 120         -> StgLiveVars
 121         -> StgLiveVars
 122         -> Id
 123         -> SRT
 124         -> StgCaseAlts
 125         -> Code
 126 \end{code}
 127
 128 Special case #1:  PrimOps returning enumeration types.
 129
 130 For enumeration types, we invent a temporary (builtin-unique 1) to
 131 hold the tag, and cross our fingers that this doesn't clash with
 132 anything else.  Builtin-unique 0 is used for a similar reason when
 133 compiling enumerated-type primops in CgExpr.lhs.  We can't use the
 134 unique from the case binder, because this is used to hold the actual
 135 closure (when the case binder is live, that is).
 136
 137 There is an extra special case for
 138
 139         case tagToEnum# x of
 140                 ...
 141
 142 which generates no code for the primop, unless x is used in the
 143 alternatives (in which case we lookup the tag in the relevant closure
 144 table to get the closure).
 145
 146 Being a bit short of uniques for temporary variables here, we use
 147 mkPseudoUnique1 to generate a temporary for the tag.  We can't use
 148 mkBuiltinUnique, because that occasionally clashes with some
 149 temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs).
 150
 151 \begin{code}
 152 cgCase (StgPrimApp op args res_ty)
 153          live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
 154   | isEnumerationTyCon tycon
 155   = getArgAmodes args `thenFC` \ arg_amodes ->
 156
 157     let tag_amode = case op of
 158                         TagToEnumOp -> only arg_amodes
 159                         _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep
 160
 161         closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
 162     in
 163
 164     case op of {
 165         TagToEnumOp -> nopC;  -- no code!
 166
 167         _ ->    -- Perform the operation
 168                getVolatileRegs live_in_alts     `thenFC` \ vol_regs ->
 169
 170                absC (COpStmt [tag_amode] op
 171                  arg_amodes -- note: no liveness arg
 172                  vol_regs)
 173     }                                           `thenC`
 174
 175         -- bind the default binder if necessary
 176         -- The deadness info is set by StgVarInfo
 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 (StgPrimApp 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              -- HWL: maybe need yield here
 605              --(if emit_yield
 606              --   then yield [node] True
 607              --   else absC AbsCNop)                            `thenC`
 608              possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
 609         -- Node is live, but doesn't need to point at the thing itself;
 610         -- it's ok for Node to point to an indirection or FETCH_ME
 611         -- Hence no need to re-enter Node.
 612     )                                   `thenFC` \ abs_c ->
 613
 614     let
 615         final_abs_c | must_label_branch = CCodeBlock lbl abs_c
 616                     | otherwise         = abs_c
 617     in
 618     returnFC final_abs_c
 619   where
 620     lbl = mkDefaultLabel uniq
 621
 622 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 623
 624 cgAlgAlt :: GCFlag
 625          -> Unique -> Maybe VirtualSpOffset -> Bool     -- turgid state
 626          -> Bool                               -- Context switch at alts?
 627          -> (DataCon, [Id], [Bool], StgExpr)
 628          -> FCode (ConTag, AbstractC)
 629
 630 cgAlgAlt gc_flag uniq cc_slot must_label_branch
 631          emit_yield{-should a yield macro be emitted?-}
 632          (con, args, use_mask, rhs)
 633   =
 634     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
 635     getAbsC (absC restore_cc `thenC`
 636              -- HWL: maybe need yield here
 637              -- (if 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         :: Unique                       -- unique for 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         -- HWL: maybe need yield here
 672         -- (if emit_yield
 673         --    then yield live_regs True         -- XXX live regs wrong?
 674         --    else absC AbsCNop)                         `thenC`
 675         let
 676               -- ToDo: could maybe use Nothing here if stack_res is False
 677               -- since the heap-check can just return to the top of the
 678               -- stack.
 679               ret_addr = Just lbl
 680         in
 681
 682         -- free up stack slots containing tags,
 683         freeStackSlots (map fst tags)           `thenC`
 684
 685         -- generate a heap check if necessary
 686         possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
 687
 688         -- and finally the code for the alternative
 689         cgExpr rhs)
 690     )
 691 \end{code}
 692
 693 %************************************************************************
 694 %*                                                                      *
 695 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 696 %*                                                                      *
 697 %************************************************************************
 698
 699 Turgid-but-non-monadic code to conjure up the required info from
 700 algebraic case alternatives for semi-tagging.
 701
 702 \begin{code}
 703 cgSemiTaggedAlts :: Id
 704                  -> [(DataCon, [Id], [Bool], StgExpr)]
 705                  -> GenStgCaseDefault Id Id
 706                  -> SemiTaggingStuff
 707
 708 cgSemiTaggedAlts binder alts deflt
 709   = Just (map st_alt alts, st_deflt deflt)
 710   where
 711     uniq        = getUnique binder
 712
 713     st_deflt StgNoDefault = Nothing
 714
 715     st_deflt (StgBindDefault _)
 716       = Just (Just binder,
 717               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 718                mkDefaultLabel uniq)
 719              )
 720
 721     st_alt (con, args, use_mask, _)
 722       =  -- Ha!  Nothing to do; Node already points to the thing
 723          (con_tag,
 724            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
 725                 [mkIntCLit (length args)], -- how big the thing in the heap is
 726              join_label)
 727             )
 728       where
 729         con_tag     = dataConTag con
 730         join_label  = mkAltLabel uniq con_tag
 731 \end{code}
 732
 733 %************************************************************************
 734 %*                                                                      *
 735 \subsection[CgCase-prim-alts]{Primitive alternatives}
 736 %*                                                                      *
 737 %************************************************************************
 738
 739 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
 740 for dealing with the alternatives of a primitive @case@, given an
 741 addressing mode for the thing to scrutinise.  It also keeps track of
 742 the maximum stack depth encountered down any branch.
 743
 744 As usual, no binders in the alternatives are yet bound.
 745
 746 \begin{code}
 747 cgPrimInlineAlts bndr ty alts deflt
 748   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
 749   where
 750         uniq = getUnique bndr
 751         kind = typePrimRep ty
 752
 753 cgPrimEvalAlts bndr ty alts deflt
 754   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
 755   where
 756         reg  = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty  )
 757                dataReturnConvPrim kind
 758         kind = typePrimRep ty
 759
 760 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
 761   =     -- first bind the default if necessary
 762     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         dataStackSlots [slot]                         `thenC`
 867         getSpRelOffset slot                           `thenFC` \ sp_rel ->
 868         returnFC (Just slot,
 869                   CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 870
 871 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 872 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 873 restoreCurrentCostCentre (Just slot)
 874  = getSpRelOffset slot                           `thenFC` \ sp_rel ->
 875    freeStackSlots [slot]                         `thenC`
 876    returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
 877     -- we use the RESTORE_CCCS macro, rather than just
 878     -- assigning into CurCostCentre, in case RESTORE_CCC
 879     -- has some sanity-checking in it.
 880 \end{code}
 881
 882 %************************************************************************
 883 %*                                                                      *
 884 \subsection[CgCase-return-vec]{Building a return vector}
 885 %*                                                                      *
 886 %************************************************************************
 887
 888 Build a return vector, and return a suitable label addressing
 889 mode for it.
 890
 891 \begin{code}
 892 mkReturnVector :: Unique
 893                -> [(ConTag, AbstractC)] -- Branch codes
 894                -> AbstractC             -- Default case
 895                -> SRT                   -- continuation's SRT
 896                -> Liveness              -- stack liveness
 897                -> CtrlReturnConvention
 898                -> FCode CAddrMode
 899
 900 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 901   = getSRTLabel `thenFC` \srt_label ->
 902     let
 903      srt_info = (srt_label, srt)
 904
 905      (return_vec_amode, vtbl_body) = case ret_conv of {
 906
 907         -- might be a polymorphic case...
 908       UnvectoredReturn 0 ->
 909         ASSERT(null tagged_alt_absCs)
 910         (CLbl ret_label RetRep,
 911          absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
 912
 913       UnvectoredReturn n ->
 914         -- find the tag explicitly rather than using tag_reg for now.
 915         -- on architectures with lots of regs the tag will be loaded
 916         -- into tag_reg by the code doing the returning.
 917         let
 918           tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
 919         in
 920         (CLbl ret_label RetRep,
 921          absC (CRetDirect uniq
 922                             (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
 923                             (srt_label, srt)
 924                             liveness));
 925
 926       VectoredReturn table_size ->
 927         let
 928           (vector_table, alts_absC) =
 929             unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 930
 931           ret_vector = CRetVector vtbl_label
 932                           vector_table
 933                           (srt_label, srt) liveness
 934         in
 935         (CLbl vtbl_label DataPtrRep,
 936          -- alts come first, because we don't want to declare all the symbols
 937          absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
 938         )
 939
 940     } in
 941     vtbl_body                                               `thenC`
 942     returnFC return_vec_amode
 943     -- )
 944   where
 945
 946     vtbl_label = mkVecTblLabel uniq
 947     ret_label = mkReturnInfoLabel uniq
 948
 949     deflt_lbl =
 950         case nonemptyAbsC deflt_absC of
 951                  -- the simplifier might have eliminated a case
 952            Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
 953            Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 954
 955     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
 956     mk_vector_entry tag
 957       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
 958              []     -> (deflt_lbl, AbsCNop)
 959              [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
 960              _      -> panic "mkReturnVector: too many"
 961 \end{code}
 962
 963 %************************************************************************
 964 %*                                                                      *
 965 \subsection[CgCase-utils]{Utilities for handling case expressions}
 966 %*                                                                      *
 967 %************************************************************************
 968
 969 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
 970 heap check or not.  These heap checks are always in a case
 971 alternative, so we use altHeapCheck.
 972
 973 \begin{code}
 974 possibleHeapCheck
 975         :: GCFlag
 976         -> Bool                         --  True <=> algebraic case
 977         -> [MagicId]                    --  live registers
 978         -> [(VirtualSpOffset,Int)]      --  stack slots to tag
 979         -> Maybe Unique                 --  return address unique
 980         -> Code                         --  continuation
 981         -> Code
 982
 983 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
 984   = altHeapCheck is_alg regs tags AbsCNop lbl code
 985 possibleHeapCheck NoGC  _ _ tags lbl code
 986   = code
 987 \end{code}
 988
 989 \begin{code}
 990 getScrutineeTyCon :: Type -> Maybe TyCon
 991 getScrutineeTyCon ty =
 992    case splitTyConApp_maybe (repType ty) of
 993         Nothing -> Nothing
 994         Just (tc,_) ->
 995                 if isFunTyCon tc  then Nothing else     -- not interested in funs
 996                 if isPrimTyCon tc then Just tc else     -- return primitive tycons
 997                         -- otherwise (algebraic tycons) check the no. of constructors
 998                 Just tc
 999 \end{code}