ghc/compiler/codeGen/CgCase.lhs

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