ghc/compiler/codeGen/CgCase.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %********************************************************
   5 %*                                                      *
   6 \section[CgCase]{Converting @StgCase@ expressions}
   7 %*                                                      *
   8 %********************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module CgCase (
  14         cgCase,
  15         saveVolatileVarsAndRegs,
  16
  17         -- and to make the interface self-sufficient...
  18         StgExpr, Id, StgCaseAlternatives, CgState
  19     ) where
  20
  21 IMPORT_Trace            -- ToDo: rm (debugging)
  22 import Outputable
  23 import Pretty
  24
  25 import StgSyn
  26 import CgMonad
  27 import AbsCSyn
  28
  29 import AbsPrel          ( PrimOp(..), primOpCanTriggerGC
  30                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  31                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  32                         )
  33 import AbsUniType       ( kindFromType, getTyConDataCons,
  34                           getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
  35                           isEnumerationTyCon,
  36                           UniType
  37                         )
  38 import CgBindery        -- all of it
  39 import CgCon            ( buildDynCon, bindConArgs )
  40 import CgExpr           ( cgExpr, getPrimOpArgAmodes )
  41 import CgHeapery        ( heapCheck )
  42 import CgRetConv        -- lots of stuff
  43 import CgStackery       -- plenty
  44 import CgTailCall       ( tailCallBusiness, performReturn )
  45 import CgUsages         -- and even more
  46 import CLabelInfo       -- bunches of things...
  47 import ClosureInfo      {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
  48                           layOutDynCon
  49                         )-}
  50 import CmdLineOpts      ( GlobalSwitch(..) )
  51 import CostCentre       ( useCurrentCostCentre, CostCentre )
  52 import BasicLit         ( kindOfBasicLit )
  53 import Id               ( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
  54                           toplevelishId, getInstantiatedDataConSig,
  55                           ConTag(..), DataCon(..)
  56                         )
  57 import Maybes           ( catMaybes, Maybe(..) )
  58 import PrimKind         ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
  59 import UniqSet          -- ( uniqSetToList, UniqSet(..) )
  60 import Util
  61 \end{code}
  62
  63 \begin{code}
  64 data GCFlag
  65   = GCMayHappen -- The scrutinee may involve GC, so everything must be
  66                 -- tidy before the code for the scrutinee.
  67
  68   | NoGC        -- The scrutinee is a primitive value, or a call to a
  69                 -- primitive op which does no GC.  Hence the case can
  70                 -- be done inline, without tidying up first.
  71 \end{code}
  72
  73 It is quite interesting to decide whether to put a heap-check
  74 at the start of each alternative.  Of course we certainly have
  75 to do so if the case forces an evaluation, or if there is a primitive
  76 op which can trigger GC.
  77
  78 A more interesting situation is this:
  79
  80 \begin{verbatim}
  81         !A!;
  82         ...A...
  83         case x# of
  84           0#      -> !B!; ...B...
  85           default -> !C!; ...C...
  86 \end{verbatim}
  87
  88 where \tr{!x!} indicates a possible heap-check point. The heap checks
  89 in the alternatives {\em can} be omitted, in which case the topmost
  90 heapcheck will take their worst case into account.
  91
  92 In favour of omitting \tr{!B!}, \tr{!C!}:
  93
  94 \begin{itemize}
  95 \item
  96 {\em May} save a heap overflow test,
  97         if ...A... allocates anything.  The other advantage
  98         of this is that we can use relative addressing
  99         from a single Hp to get at all the closures so allocated.
 100 \item
 101  No need to save volatile vars etc across the case
 102 \end{itemize}
 103
 104 Against:
 105
 106 \begin{itemize}
 107 \item
 108    May do more allocation than reqd.  This sometimes bites us
 109         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
 110         worst-casing is done, because many many calls to nfib are leaf calls
 111         which don't need to allocate anything.
 112
 113         This never hurts us if there is only one alternative.
 114 \end{itemize}
 115
 116
 117 *** NOT YET DONE ***  The difficulty is that \tr{!B!}, \tr{!C!} need
 118 to take account of what is live, and that includes all live volatile
 119 variables, even if they also have stable analogues.  Furthermore, the
 120 stack pointers must be lined up properly so that GC sees tidy stacks.
 121 If these things are done, then the heap checks can be done at \tr{!B!} and
 122 \tr{!C!} without a full save-volatile-vars sequence.
 123
 124 \begin{code}
 125 cgCase  :: PlainStgExpr
 126         -> PlainStgLiveVars
 127         -> PlainStgLiveVars
 128         -> Unique
 129         -> PlainStgCaseAlternatives
 130         -> Code
 131 \end{code}
 132
 133 Several special cases for primitive operations.
 134
 135 ******* TO DO TO DO: fix what follows
 136
 137 Special case for
 138
 139         case (op x1 ... xn) of
 140           y -> e
 141
 142 where the type of the case scrutinee is a multi-constuctor algebraic type.
 143 Then we simply compile code for
 144
 145         let y = op x1 ... xn
 146         in
 147         e
 148
 149 In this case:
 150
 151         case (op x1 ... xn) of
 152            C a b -> ...
 153            y     -> e
 154
 155 where the type of the case scrutinee is a multi-constuctor algebraic type.
 156 we just bomb out at the moment. It never happens in practice.
 157
 158 **** END OF TO DO TO DO
 159
 160 \begin{code}
 161 cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq
 162        (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
 163   = if not (null alts) then
 164         panic "cgCase: case on PrimOp with default *and* alts\n"
 165         -- For now, die if alts are non-empty
 166     else
 167 #if 0
 168         pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
 169         -- See above TO DO TO DO
 170 #endif
 171         cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
 172   where
 173     scrut_rhs       = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
 174                                 Updatable [] scrut
 175     scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ]
 176                         -- Hack, hack
 177 \end{code}
 178
 179
 180 \begin{code}
 181 cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
 182   | not (primOpCanTriggerGC op)
 183   =
 184         -- Get amodes for the arguments and results
 185     getPrimOpArgAmodes op args                  `thenFC` \ arg_amodes ->
 186     let
 187         result_amodes = getPrimAppResultAmodes uniq alts
 188         liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
 189     in
 190         -- Perform the operation
 191     getVolatileRegs live_in_alts                        `thenFC` \ vol_regs ->
 192
 193     profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]  `thenC`
 194
 195     absC (COpStmt result_amodes op
 196                  arg_amodes -- note: no liveness arg
 197                  liveness_mask vol_regs)                `thenC`
 198
 199     profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]  `thenC`
 200
 201         -- Scrutinise the result
 202     cgInlineAlts NoGC uniq alts
 203
 204   | otherwise   -- *Can* trigger GC
 205   = getPrimOpArgAmodes op args          `thenFC` \ arg_amodes ->
 206
 207         -- Get amodes for the arguments and results, and assign to regs
 208         -- (Can-trigger-gc primops guarantee to have their (nonRobust)
 209         --  args in regs)
 210     let
 211         op_result_regs = assignPrimOpResultRegs op
 212
 213         op_result_amodes = map CReg op_result_regs
 214
 215         (op_arg_amodes, liveness_mask, arg_assts)
 216           = makePrimOpArgsRobust op arg_amodes
 217
 218         liveness_arg  = mkIntCLit liveness_mask
 219     in
 220         -- Tidy up in case GC happens...
 221
 222         -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
 223         -- Reason: the arg_assts computed above may refer to some stack slots
 224         -- which are not live in the alts.  So we mustn't use those slots
 225         -- to save volatile vars in!
 226     nukeDeadBindings live_in_whole_case `thenC`
 227     saveVolatileVars live_in_alts       `thenFC` \ volatile_var_save_assts ->
 228
 229     getEndOfBlockInfo                   `thenFC` \ eob_info ->
 230     forkEval eob_info nopC
 231              (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
 232               absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
 233                                         `thenC`
 234               returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
 235                                  Nothing{-no semi-tagging-}))
 236             `thenFC` \ new_eob_info ->
 237
 238         -- Record the continuation info
 239     setEndOfBlockInfo new_eob_info (
 240
 241         -- Now "return" to the inline alternatives; this will get
 242         -- compiled to a fall-through.
 243     let
 244         simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
 245
 246         -- do_op_and_continue will be passed an amode for the continuation
 247         do_op_and_continue sequel
 248           = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]  `thenC`
 249
 250             absC (COpStmt op_result_amodes
 251                           op
 252                           (pin_liveness op liveness_arg op_arg_amodes)
 253                           liveness_mask
 254                           [{-no vol_regs-}])
 255                                         `thenC`
 256
 257             profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]  `thenC`
 258
 259             sequelToAmode sequel        `thenFC` \ dest_amode ->
 260             absC (CReturn dest_amode DirectReturn)
 261
 262                 -- Note: we CJump even for algebraic data types,
 263                 -- because cgInlineAlts always generates code, never a
 264                 -- vector.
 265     in
 266     performReturn simultaneous_assts do_op_and_continue live_in_alts
 267     )
 268   where
 269     -- for all PrimOps except ccalls, we pin the liveness info
 270     -- on as the first "argument"
 271     -- ToDo: un-duplicate?
 272
 273     pin_liveness (CCallOp _ _ _ _ _) _ args = args
 274     pin_liveness other_op liveness_arg args
 275       = liveness_arg :args
 276
 277     vtbl_label = mkVecTblLabel uniq
 278     return_label = mkReturnPtLabel uniq
 279
 280 \end{code}
 281
 282 Another special case: scrutinising a primitive-typed variable.  No
 283 evaluation required.  We don't save volatile variables, nor do we do a
 284 heap-check in the alternatives.  Instead, the heap usage of the
 285 alternatives is worst-cased and passed upstream.  This can result in
 286 allocating more heap than strictly necessary, but it will sometimes
 287 eliminate a heap check altogether.
 288
 289 \begin{code}
 290 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
 291   = getAtomAmode v              `thenFC` \ amode ->
 292     cgPrimAltsGivenScrutinee NoGC amode alts deflt
 293 \end{code}
 294
 295 Special case: scrutinising a non-primitive variable.
 296 This can be done a little better than the general case, because
 297 we can reuse/trim the stack slot holding the variable (if it is in one).
 298
 299 \begin{code}
 300 cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-})
 301         live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
 302   =
 303     getCAddrModeAndInfo fun             `thenFC` \ (fun_amode, lf_info) ->
 304     getAtomAmodes args                  `thenFC` \ arg_amodes ->
 305
 306         -- Squish the environment
 307     nukeDeadBindings live_in_alts       `thenC`
 308     saveVolatileVarsAndRegs live_in_alts
 309                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 310
 311     forkEval alts_eob_info
 312              nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
 313     setEndOfBlockInfo scrut_eob_info  (
 314       tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
 315     )
 316
 317 \end{code}
 318
 319 Finally, here is the general case.
 320
 321 \begin{code}
 322 cgCase expr live_in_whole_case live_in_alts uniq alts
 323   =     -- Figure out what volatile variables to save
 324     nukeDeadBindings live_in_whole_case `thenC`
 325     saveVolatileVarsAndRegs live_in_alts
 326                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 327
 328         -- Save those variables right now!
 329     absC save_assts                     `thenC`
 330
 331     forkEval alts_eob_info
 332         (nukeDeadBindings live_in_alts)
 333         (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
 334
 335     setEndOfBlockInfo scrut_eob_info (cgExpr expr)
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[CgCase-primops]{Primitive applications}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 Get result amodes for a primitive operation, in the case wher GC can't happen.
 345 The  amodes are returned in canonical order, ready for the prim-op!
 346
 347         Alg case: temporaries named as in the alternatives,
 348                   plus (CTemp u) for the tag (if needed)
 349         Prim case: (CTemp u)
 350
 351 This is all disgusting, because these amodes must be consistent with those
 352 invented by CgAlgAlts.
 353
 354 \begin{code}
 355 getPrimAppResultAmodes
 356         :: Unique
 357         -> PlainStgCaseAlternatives
 358         -> [CAddrMode]
 359 \end{code}
 360
 361 \begin{code}
 362 -- If there's an StgBindDefault which does use the bound
 363 -- variable, then we can only handle it if the type involved is
 364 -- an enumeration type.   That's important in the case
 365 -- of comparisions:
 366 --
 367 --      case x ># y of
 368 --        r -> f r
 369 --
 370 -- The only reason for the restriction to *enumeration* types is our
 371 -- inability to invent suitable temporaries to hold the results;
 372 -- Elaborating the CTemp addr mode to have a second uniq field
 373 -- (which would simply count from 1) would solve the problem.
 374 -- Anyway, cgInlineAlts is now capable of handling all cases;
 375 -- it's only this function which is being wimpish.
 376
 377 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
 378   | isEnumerationTyCon spec_tycon = [tag_amode]
 379   | otherwise                     = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
 380   where
 381     -- A temporary variable to hold the tag; this is unaffected by GC because
 382     -- the heap-checks in the branches occur after the switch
 383     tag_amode     = CTemp uniq IntKind
 384     (spec_tycon, _, _) = getUniDataSpecTyCon ty
 385
 386 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
 387         -- Default is either StgNoDefault or StgBindDefault with unused binder
 388   = case alts of
 389         [_]     -> arg_amodes                   -- No need for a tag
 390         other   -> tag_amode : arg_amodes
 391   where
 392     -- A temporary variable to hold the tag; this is unaffected by GC because
 393     -- the heap-checks in the branches occur after the switch
 394     tag_amode = CTemp uniq IntKind
 395
 396     -- Sort alternatives into canonical order; there must be a complete
 397     -- set because there's no default case.
 398     sorted_alts = sortLt lt alts
 399     (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
 400
 401     arg_amodes :: [CAddrMode]
 402
 403     -- Turn them into amodes
 404     arg_amodes = concat (map mk_amodes sorted_alts)
 405     mk_amodes (con, args, use_mask, rhs)
 406       = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ]
 407 \end{code}
 408
 409 The situation is simpler for primitive
 410 results, because there is only one!
 411
 412 \begin{code}
 413 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
 414   = [CTemp uniq kind]
 415   where
 416     kind = kindFromType ty
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection[CgCase-alts]{Alternatives}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 @cgEvalAlts@ returns an addressing mode for a continuation for the
 427 alternatives of a @case@, used in a context when there
 428 is some evaluation to be done.
 429
 430 \begin{code}
 431 cgEvalAlts :: Maybe VirtualSpBOffset    -- Offset of cost-centre to be restored, if any
 432            -> Unique
 433            -> PlainStgCaseAlternatives
 434            -> FCode Sequel              -- Any addr modes inside are guaranteed to be a label
 435                                         -- so that we can duplicate it without risk of
 436                                         -- duplicating code
 437
 438 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
 439   =     -- Generate the instruction to restore cost centre, if any
 440     restoreCurrentCostCentre cc_slot    `thenFC` \ cc_restore ->
 441
 442         -- Generate sequel info for use downstream
 443         -- At the moment, we only do it if the type is vector-returnable.
 444         -- Reason: if not, then it costs extra to label the
 445         -- alternatives, because we'd get return code like:
 446         --
 447         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
 448         --
 449         -- which is worse than having the alt code in the switch statement
 450
 451     let
 452         (spec_tycon, _, _) = getUniDataSpecTyCon ty
 453
 454         use_labelled_alts
 455           = case ctrlReturnConvAlg spec_tycon of
 456               VectoredReturn _ -> True
 457               _                -> False
 458
 459         semi_tagged_stuff
 460           = if not use_labelled_alts then
 461                 Nothing -- no semi-tagging info
 462             else
 463                 cgSemiTaggedAlts uniq alts deflt -- Just <something>
 464     in
 465     cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
 466                                         `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 467
 468     mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
 469
 470     returnFC (CaseAlts return_vec semi_tagged_stuff)
 471
 472 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
 473   =     -- Generate the instruction to restore cost centre, if any
 474     restoreCurrentCostCentre cc_slot                     `thenFC` \ cc_restore ->
 475
 476         -- Generate the switch
 477     getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt)  `thenFC` \ abs_c ->
 478
 479         -- Generate the labelled block, starting with restore-cost-centre
 480     absC (CRetUnVector vtbl_label
 481          (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
 482                                                          `thenC`
 483         -- Return an amode for the block
 484     returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
 485   where
 486     vtbl_label = mkVecTblLabel uniq
 487     return_label = mkReturnPtLabel uniq
 488 \end{code}
 489
 490
 491 \begin{code}
 492 cgInlineAlts :: GCFlag -> Unique
 493              -> PlainStgCaseAlternatives
 494              -> Code
 495 \end{code}
 496
 497 First case: algebraic case, exactly one alternative, no default.
 498 In this case the primitive op will not have set a temporary to the
 499 tag, so we shouldn't generate a switch statment.  Instead we just
 500 do the right thing.
 501
 502 \begin{code}
 503 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
 504   = cgAlgAltRhs gc_flag con args use_mask rhs
 505 \end{code}
 506
 507 Second case: algebraic case, several alternatives.
 508 Tag is held in a temporary.
 509
 510 \begin{code}
 511 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
 512   = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
 513                 ty alts deflt   `thenFC` \ (tagged_alts, deflt_c) ->
 514
 515         -- Do the switch
 516     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 517  where
 518     -- A temporary variable to hold the tag; this is unaffected by GC because
 519     -- the heap-checks in the branches occur after the switch
 520     tag_amode = CTemp uniq IntKind
 521 \end{code}
 522
 523 =========== OLD: we *can* now handle this case ================
 524
 525 Next, a case we can't deal with: an algebraic case with no evaluation
 526 required (so it is in-line), and a default case as well.  In this case
 527 we require all the alternatives written out, so that we can invent
 528 suitable binders to pass to the PrimOp. A default case defeats this.
 529 Could be fixed, but probably isn't worth it.
 530
 531 \begin{code}
 532 {- ============= OLD
 533 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
 534   = panic "cgInlineAlts: alg alts with default"
 535 ================= END OF OLD -}
 536 \end{code}
 537
 538 Third (real) case: primitive result type.
 539
 540 \begin{code}
 541 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
 542   = cgPrimAlts gc_flag uniq ty alts deflt
 543 \end{code}
 544
 545
 546 %************************************************************************
 547 %*                                                                      *
 548 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 549 %*                                                                      *
 550 %************************************************************************
 551
 552 In @cgAlgAlts@, none of the binders in the alternatives are
 553 assumed to be yet bound.
 554
 555 \begin{code}
 556 cgAlgAlts :: GCFlag
 557           -> Unique
 558           -> AbstractC                          -- Restore-cost-centre instruction
 559           -> Bool                               -- True <=> branches must be labelled
 560           -> UniType                            -- From the case statement
 561           -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives
 562           -> PlainStgCaseDefault                -- The default
 563           -> FCode ([(ConTag, AbstractC)],      -- The branches
 564                     AbstractC                   -- The default case
 565              )
 566 \end{code}
 567
 568 The case with a default which has a binder is different.  We need to
 569 pick all the constructors which aren't handled explicitly by an
 570 alternative, and which return their results in registers, allocate
 571 them explicitly in the heap, and jump to a join point for the default
 572 case.
 573
 574 OLD:  All of this only works if a heap-check is required anyway, because
 575 otherwise it isn't safe to allocate.
 576
 577 NEW (July 94): now false!  It should work regardless of gc_flag,
 578 because of the extra_branches argument now added to forkAlts.
 579
 580 We put a heap-check at the join point, for the benefit of constructors
 581 which don't need to do allocation. This means that ones which do need
 582 to allocate may end up doing two heap-checks; but that's just too bad.
 583 (We'd need two join labels otherwise.  ToDo.)
 584
 585 It's all pretty turgid anyway.
 586
 587 \begin{code}
 588 cgAlgAlts gc_flag uniq restore_cc semi_tagging
 589         ty alts deflt@(StgBindDefault binder True{-used-} _)
 590   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
 591              extra_branches
 592              (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt)
 593   where
 594     extra_branches :: [FCode (ConTag, AbstractC)]
 595     extra_branches = catMaybes (map mk_extra_branch default_cons)
 596
 597     must_label_default = semi_tagging || not (null extra_branches)
 598
 599     default_join_lbl = mkDefaultLabel uniq
 600     jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
 601
 602     (spec_tycon, _, spec_cons)
 603       = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
 604         --      ppr PprDebug uniq,
 605         --      ppr PprDebug ty,
 606         --      ppr PprShowAll binder
 607         --      ]))) (
 608         getUniDataSpecTyCon ty
 609         -- )
 610
 611     alt_cons = [ con | (con,_,_,_) <- alts ]
 612
 613     default_cons  = [ spec_con | spec_con <- spec_cons, -- In this type
 614                                  spec_con `not_elem` alt_cons ] -- Not handled explicitly
 615         where
 616           not_elem = isn'tIn "cgAlgAlts"
 617
 618     -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
 619     -- The "maybe" is because con may return in heap, in which case there is
 620     -- nothing to do. Otherwise, we have a special case for a nullary constructor,
 621     -- but in the general case we do an allocation and heap-check.
 622
 623     mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
 624
 625     mk_extra_branch con
 626       = ASSERT(isDataCon con)
 627         case dataReturnConvAlg con of
 628           ReturnInHeap    -> Nothing
 629           ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
 630                                    returnFC (tag, abs_c)
 631                                   )
 632       where
 633         lf_info         = mkConLFInfo con
 634         tag             = getDataConTag con
 635         closure_lbl     = mkClosureLabel con
 636
 637         -- alloc_code generates code to allocate constructor con, whose args are
 638         -- in the arguments to alloc_code, assigning the result to Node.
 639         alloc_code :: [MagicId] -> Code
 640
 641         alloc_code regs
 642           = possibleHeapCheck gc_flag regs False (
 643                 buildDynCon binder useCurrentCostCentre con
 644                                 (map CReg regs) (all zero_size regs)
 645                                                 `thenFC` \ idinfo ->
 646                 idInfoToAmode PtrKind idinfo    `thenFC` \ amode ->
 647
 648                 absC (CAssign (CReg node) amode) `thenC`
 649                 absC jump_instruction
 650             )
 651           where
 652             zero_size reg = getKindSize (kindFromMagicId reg) == 0
 653 \end{code}
 654
 655 Now comes the general case
 656
 657 \begin{code}
 658 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
 659         {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
 660   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
 661              [{- No "extra branches" -}]
 662              (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
 663 \end{code}
 664
 665 \begin{code}
 666 cgAlgDefault :: GCFlag
 667              -> Unique -> AbstractC -> Bool -- turgid state...
 668              -> PlainStgCaseDefault         -- input
 669              -> FCode AbstractC             -- output
 670
 671 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 672              StgNoDefault
 673   = returnFC AbsCNop
 674
 675 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 676              (StgBindDefault _ False{-binder not used-} rhs)
 677
 678   = getAbsC (absC restore_cc `thenC`
 679              possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
 680     let
 681         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 682                     | otherwise         = abs_c
 683     in
 684     returnFC final_abs_c
 685   where
 686     lbl = mkDefaultLabel uniq
 687
 688
 689 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 690              (StgBindDefault binder True{-binder used-} rhs)
 691
 692   =     -- We have arranged that Node points to the thing, even
 693         -- even if we return in registers
 694     bindNewToReg binder node mkLFArgument `thenC`
 695     getAbsC (absC restore_cc `thenC`
 696              possibleHeapCheck gc_flag [node] False (cgExpr rhs)
 697         -- Node is live, but doesn't need to point at the thing itself;
 698         -- it's ok for Node to point to an indirection or FETCH_ME
 699         -- Hence no need to re-enter Node.
 700     )                                   `thenFC` \ abs_c ->
 701
 702     let
 703         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 704                     | otherwise         = abs_c
 705     in
 706     returnFC final_abs_c
 707   where
 708     lbl = mkDefaultLabel uniq
 709
 710
 711 cgAlgAlt :: GCFlag
 712          -> Unique -> AbstractC -> Bool         -- turgid state
 713          -> (Id, [Id], [Bool], PlainStgExpr)
 714          -> FCode (ConTag, AbstractC)
 715
 716 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
 717   = getAbsC (absC restore_cc `thenC`
 718              cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
 719     let
 720         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 721                     | otherwise         = abs_c
 722     in
 723     returnFC (tag, final_abs_c)
 724   where
 725     tag = getDataConTag con
 726     lbl = mkAltLabel uniq tag
 727
 728 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
 729
 730 cgAlgAltRhs gc_flag con args use_mask rhs
 731   = let
 732       (live_regs, node_reqd)
 733         = case (dataReturnConvAlg con) of
 734             ReturnInHeap      -> ([],                                             True)
 735             ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
 736                                 -- Pick the live registers using the use_mask
 737                                 -- Doing so is IMPORTANT, because with semi-tagging
 738                                 -- enabled only the live registers will have valid
 739                                 -- pointers in them.
 740     in
 741     possibleHeapCheck gc_flag live_regs node_reqd (
 742     (case gc_flag of
 743         NoGC        -> mapFCs bindNewToTemp args `thenFC` \ _ ->
 744                        nopC
 745         GCMayHappen -> bindConArgs con args
 746     )   `thenC`
 747     cgExpr rhs
 748     )
 749 \end{code}
 750
 751 %************************************************************************
 752 %*                                                                      *
 753 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 Turgid-but-non-monadic code to conjure up the required info from
 758 algebraic case alternatives for semi-tagging.
 759
 760 \begin{code}
 761 cgSemiTaggedAlts :: Unique
 762                  -> [(Id, [Id], [Bool], PlainStgExpr)]
 763                  -> StgCaseDefault Id Id
 764                  -> SemiTaggingStuff
 765
 766 cgSemiTaggedAlts uniq alts deflt
 767   = Just (map st_alt alts, st_deflt deflt)
 768   where
 769     st_deflt StgNoDefault = Nothing
 770
 771     st_deflt (StgBindDefault binder binder_used _)
 772       = Just (if binder_used then Just binder else Nothing,
 773               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
 774                mkDefaultLabel uniq)
 775              )
 776
 777     st_alt (con, args, use_mask, _)
 778       = case (dataReturnConvAlg con) of
 779
 780           ReturnInHeap ->
 781             -- Ha!  Nothing to do; Node already points to the thing
 782             (con_tag,
 783              (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") [], -- ToDo: monadise?
 784              join_label)
 785             )
 786
 787           ReturnInRegs regs ->
 788             -- We have to load the live registers from the constructor
 789             -- pointed to by Node.
 790             let
 791                 (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
 792
 793                 used_regs = selectByMask use_mask regs
 794
 795                 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
 796                                              reg `is_elem` used_regs]
 797
 798                 is_elem = isIn "cgSemiTaggedAlts"
 799             in
 800             (con_tag,
 801              (mkAbstractCs [
 802                 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") [], -- ToDo: macroise?
 803                 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
 804               join_label))
 805       where
 806         con_tag     = getDataConTag con
 807         join_label  = mkAltLabel uniq con_tag
 808
 809     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
 810     move_to_reg (reg, offset)
 811       = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
 812
 813 \end{code}
 814
 815 %************************************************************************
 816 %*                                                                      *
 817 \subsection[CgCase-prim-alts]{Primitive alternatives}
 818 %*                                                                      *
 819 %************************************************************************
 820
 821 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
 822 alternatives of a primitive @case@, given an addressing mode for the
 823 thing to scrutinise.  It also keeps track of the maximum stack depth
 824 encountered down any branch.
 825
 826 As usual, no binders in the alternatives are yet bound.
 827
 828 \begin{code}
 829 cgPrimAlts :: GCFlag
 830            -> Unique
 831            -> UniType
 832            -> [(BasicLit, PlainStgExpr)]        -- Alternatives
 833            -> PlainStgCaseDefault               -- Default
 834            -> Code
 835
 836 cgPrimAlts gc_flag uniq ty alts deflt
 837   = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
 838  where
 839     -- A temporary variable, or standard register, to hold the result
 840     scrutinee = case gc_flag of
 841                      NoGC        -> CTemp uniq kind
 842                      GCMayHappen -> CReg (dataReturnConvPrim kind)
 843
 844     kind = kindFromType ty
 845
 846
 847 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
 848   = forkAlts (map (cgPrimAlt gc_flag) alts)
 849              [{- No "extra branches" -}]
 850              (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
 851     absC (CSwitch scrutinee alt_absCs deflt_absC)
 852           -- CSwitch does sensible things with one or zero alternatives
 853
 854
 855 cgPrimAlt :: GCFlag
 856           -> (BasicLit, PlainStgExpr)    -- The alternative
 857           -> FCode (BasicLit, AbstractC) -- Its compiled form
 858
 859 cgPrimAlt gc_flag (lit, rhs)
 860   = getAbsC rhs_code     `thenFC` \ absC ->
 861     returnFC (lit,absC)
 862   where
 863     rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
 864
 865 cgPrimDefault :: GCFlag
 866               -> CAddrMode              -- Scrutinee
 867               -> PlainStgCaseDefault
 868               -> FCode AbstractC
 869
 870 cgPrimDefault gc_flag scrutinee StgNoDefault
 871   = panic "cgPrimDefault: No default in prim case"
 872
 873 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
 874   = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
 875
 876 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
 877   = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
 878   where
 879     regs = if isFollowableKind (getAmodeKind scrutinee) then
 880               [node] else []
 881
 882     rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
 883                cgExpr rhs
 884 \end{code}
 885
 886
 887 %************************************************************************
 888 %*                                                                      *
 889 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
 890 %*                                                                      *
 891 %************************************************************************
 892
 893 \begin{code}
 894 saveVolatileVarsAndRegs
 895     :: PlainStgLiveVars               -- Vars which should be made safe
 896     -> FCode (AbstractC,              -- Assignments to do the saves
 897        EndOfBlockInfo,                -- New sequel, recording where the return
 898                                       -- address now is
 899        Maybe VirtualSpBOffset)        -- Slot for current cost centre
 900
 901
 902 saveVolatileVarsAndRegs vars
 903   = saveVolatileVars vars     `thenFC` \ var_saves ->
 904     saveCurrentCostCentre     `thenFC` \ (maybe_cc_slot, cc_save) ->
 905     saveReturnAddress         `thenFC` \ (new_eob_info, ret_save) ->
 906     returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
 907               new_eob_info,
 908               maybe_cc_slot)
 909
 910
 911 saveVolatileVars :: PlainStgLiveVars    -- Vars which should be made safe
 912                  -> FCode AbstractC     -- Assignments to to the saves
 913
 914 saveVolatileVars vars
 915   = save_em (uniqSetToList vars)
 916   where
 917     save_em [] = returnFC AbsCNop
 918
 919     save_em (var:vars)
 920       = getCAddrModeIfVolatile var `thenFC` \ v ->
 921         case v of
 922             Nothing         -> save_em vars -- Non-volatile, so carry on
 923
 924
 925             Just vol_amode  ->  -- Aha! It's volatile
 926                                save_var var vol_amode   `thenFC` \ abs_c ->
 927                                save_em vars             `thenFC` \ abs_cs ->
 928                                returnFC (abs_c `mkAbsCStmts` abs_cs)
 929
 930     save_var var vol_amode
 931       | isFollowableKind kind
 932       = allocAStack                     `thenFC` \ a_slot ->
 933         rebindToAStack var a_slot       `thenC`
 934         getSpARelOffset a_slot          `thenFC` \ spa_rel ->
 935         returnFC (CAssign (CVal spa_rel kind) vol_amode)
 936       | otherwise
 937       = allocBStack (getKindSize kind)  `thenFC` \ b_slot ->
 938         rebindToBStack var b_slot       `thenC`
 939         getSpBRelOffset b_slot          `thenFC` \ spb_rel ->
 940         returnFC (CAssign (CVal spb_rel kind) vol_amode)
 941       where
 942         kind = getAmodeKind vol_amode
 943
 944 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
 945 saveReturnAddress
 946   = getEndOfBlockInfo                `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
 947
 948       -- See if it is volatile
 949     case sequel of
 950       InRetReg ->     -- Yes, it's volatile
 951                    allocBStack retKindSize    `thenFC` \ b_slot ->
 952                    getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
 953
 954                    returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
 955                              CAssign (CVal spb_rel RetKind) (CReg RetReg))
 956
 957       UpdateCode _ ->   -- It's non-volatile all right, but we still need
 958                         -- to allocate a B-stack slot for it, *solely* to make
 959                         -- sure that update frames for different values do not
 960                         -- appear adjacent on the B stack. This makes sure
 961                         -- that B-stack squeezing works ok.
 962                         -- See note below
 963                    allocBStack retKindSize    `thenFC` \ b_slot ->
 964                    returnFC (eob_info, AbsCNop)
 965
 966       other ->           -- No, it's non-volatile, so do nothing
 967                    returnFC (eob_info, AbsCNop)
 968 \end{code}
 969
 970 Note about B-stack squeezing.  Consider the following:`
 971
 972         y = [...] \u [] -> ...
 973         x = [y]   \u [] -> case y of (a,b) -> a
 974
 975 The code for x will push an update frame, and then enter y.  The code
 976 for y will push another update frame.  If the B-stack-squeezer then
 977 wakes up, it will see two update frames right on top of each other,
 978 and will combine them.  This is WRONG, of course, because x's value is
 979 not the same as y's.
 980
 981 The fix implemented above makes sure that we allocate an (unused)
 982 B-stack slot before entering y.  You can think of this as holding the
 983 saved value of RetAddr, which (after pushing x's update frame will be
 984 some update code ptr).  The compiler is clever enough to load the
 985 static update code ptr into RetAddr before entering ~a~, but the slot
 986 is still there to separate the update frames.
 987
 988 When we save the current cost centre (which is done for lexical
 989 scoping), we allocate a free B-stack location, and return (a)~the
 990 virtual offset of the location, to pass on to the alternatives, and
 991 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 992
 993 \begin{code}
 994 saveCurrentCostCentre ::
 995         FCode (Maybe VirtualSpBOffset,  -- Where we decide to store it
 996                                         --   Nothing if not lexical CCs
 997                AbstractC)               -- Assignment to save it
 998                                         --   AbsCNop if not lexical CCs
 999
1000 saveCurrentCostCentre
1001   = isSwitchSetC SccProfilingOn         `thenFC` \ doing_profiling ->
1002     if not doing_profiling then
1003         returnFC (Nothing, AbsCNop)
1004     else
1005         allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
1006         getSpBRelOffset b_slot                   `thenFC` \ spb_rel ->
1007         returnFC (Just b_slot,
1008                   CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
1009
1010 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1011
1012 restoreCurrentCostCentre Nothing
1013  = returnFC AbsCNop
1014 restoreCurrentCostCentre (Just b_slot)
1015  = getSpBRelOffset b_slot                        `thenFC` \ spb_rel ->
1016    freeBStkSlot b_slot                           `thenC`
1017    returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
1018     -- we use the RESTORE_CCC macro, rather than just
1019     -- assigning into CurCostCentre, in case RESTORE_CCC
1020     -- has some sanity-checking in it.
1021 \end{code}
1022
1023
1024 %************************************************************************
1025 %*                                                                      *
1026 \subsection[CgCase-return-vec]{Building a return vector}
1027 %*                                                                      *
1028 %************************************************************************
1029
1030 Build a return vector, and return a suitable label addressing
1031 mode for it.
1032
1033 \begin{code}
1034 mkReturnVector :: Unique
1035                -> UniType
1036                -> [(ConTag, AbstractC)] -- Branch codes
1037                -> AbstractC             -- Default case
1038                -> FCode CAddrMode
1039
1040 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1041   = let
1042      (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1043
1044       UnvectoredReturn _ ->
1045         (CUnVecLbl ret_label vtbl_label,
1046          absC (CRetUnVector vtbl_label
1047                             (CLabelledCode ret_label
1048                                            (mkAlgAltsCSwitch (CReg TagReg)
1049                                                              tagged_alt_absCs
1050                                                              deflt_absC))));
1051       VectoredReturn table_size ->
1052         (CLbl vtbl_label DataPtrKind,
1053          absC (CRetVector vtbl_label
1054                         -- must restore cc before each alt, if required
1055                           (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1056                           deflt_absC))
1057
1058 -- Leave nops and comments in for now; they are eliminated
1059 -- lazily as it's printed.
1060 --                        (case (nonemptyAbsC deflt_absC) of
1061 --                              Nothing  -> AbsCNop
1062 --                              Just def -> def)
1063
1064     } in
1065     vtbl_body                                               `thenC`
1066     returnFC return_vec_amode
1067     -- )
1068   where
1069
1070     (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
1071               Just xx -> xx
1072               Nothing -> error ("ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: "++(ppShow 80 (ppr PprDebug ty)))
1073
1074     vtbl_label = mkVecTblLabel uniq
1075     ret_label = mkReturnPtLabel uniq
1076
1077     mk_vector_entry :: ConTag -> Maybe CAddrMode
1078     mk_vector_entry tag
1079       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1080              []     -> Nothing
1081              [absC] -> Just (CCode absC)
1082              _      -> panic "mkReturnVector: too many"
1083 \end{code}
1084
1085 %************************************************************************
1086 %*                                                                      *
1087 \subsection[CgCase-utils]{Utilities for handling case expressions}
1088 %*                                                                      *
1089 %************************************************************************
1090
1091 @possibleHeapCheck@ tests a flag passed in to decide whether to
1092 do a heap check or not.
1093
1094 \begin{code}
1095 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1096
1097 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1098 possibleHeapCheck NoGC        _    _         code = code
1099 \end{code}
1100
1101 Select a restricted set of registers based on a usage mask.
1102
1103 \begin{code}
1104 selectByMask []         []         = []
1105 selectByMask (True:ms)  (x:xs) = x : selectByMask ms xs
1106 selectByMask (False:ms) (x:xs) = selectByMask ms xs
1107 \end{code}