ghc/compiler/codeGen/CgCase.lhs

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