ghc/compiler/codeGen/CgCase.lhs

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