ghc/compiler/codeGen/CgTailCall.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgTailCall.lhs,v 1.35 2002/10/25 16:54:56 simonpj Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgTailCall]{Tail calls: converting @StgApps@}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgTailCall (
  14         cgTailCall,
  15         performReturn, performPrimReturn,
  16         mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
  17         mkUnboxedTupleReturnCode, returnUnboxedTuple,
  18         mkPrimReturnCode,
  19
  20         tailCallFun,
  21         tailCallPrimOp,
  22         doTailCall,
  23
  24         pushReturnAddress
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import CgMonad
  30 import AbsCSyn
  31
  32 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  33 import CgBindery        ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
  34 import CgRetConv        ( dataReturnConvPrim,
  35                           ctrlReturnConvAlg, CtrlReturnConvention(..),
  36                           assignAllRegs, assignRegs
  37                         )
  38 import CgStackery       ( mkTaggedStkAmodes, adjustStackHW )
  39 import CgUsages         ( getSpRelOffset, adjustSpAndHp )
  40 import CgUpdate         ( pushSeqFrame )
  41 import CLabel           ( mkUpdInfoLabel, mkRtsPrimOpLabel )
  42 import ClosureInfo      ( nodeMustPointToIt,
  43                           getEntryConvention, EntryConvention(..), LambdaFormInfo
  44                         )
  45 import CmdLineOpts      ( opt_DoSemiTagging )
  46 import Id               ( Id, idType, idName )
  47 import DataCon          ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
  48 import Maybes           ( maybeToBool )
  49 import PrimRep          ( PrimRep(..) )
  50 import StgSyn           ( StgArg )
  51 import Type             ( isUnLiftedType )
  52 import TyCon            ( TyCon )
  53 import PrimOp           ( PrimOp )
  54 import Util             ( zipWithEqual, splitAtList )
  55 import ListSetOps       ( assocMaybe )
  56 import Outputable
  57 import Panic            ( panic, assertPanic )
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection[tailcall-doc]{Documentation}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 \begin{code}
  67 cgTailCall :: Id -> [StgArg] -> Code
  68 \end{code}
  69
  70 Here's the code we generate for a tail call.  (NB there may be no
  71 arguments, in which case this boils down to just entering a variable.)
  72
  73 \begin{itemize}
  74 \item   Adjust the stack ptr to \tr{tailSp + #args}.
  75 \item   Put args in the top locations of the resulting stack.
  76 \item   Make Node point to the function closure.
  77 \item   Enter the function closure.
  78 \end{itemize}
  79
  80 Things to be careful about:
  81 \begin{itemize}
  82 \item   Don't overwrite stack locations before you have finished with
  83         them (remember you need the function and the as-yet-unmoved
  84         arguments).
  85 \item   Preferably, generate no code to replace x by x on the stack (a
  86         common situation in tail-recursion).
  87 \item   Adjust the stack high water mark appropriately.
  88 \end{itemize}
  89
  90 Treat unboxed locals exactly like literals (above) except use the addr
  91 mode for the local instead of (CLit lit) in the assignment.
  92
  93 Case for unboxed @Ids@ first:
  94 \begin{code}
  95 cgTailCall fun []
  96   | isUnLiftedType (idType fun)
  97   = getCAddrMode fun            `thenFC` \ amode ->
  98     performPrimReturn (ppr fun) amode
  99 \end{code}
 100
 101 The general case (@fun@ is boxed):
 102 \begin{code}
 103 cgTailCall fun args = performTailCall fun args
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsection[return-and-tail-call]{Return and tail call}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 \begin{code}
 113 performPrimReturn :: SDoc       -- Just for debugging (sigh)
 114                   -> CAddrMode  -- The thing to return
 115                   -> Code
 116
 117 performPrimReturn doc amode
 118   = let
 119         kind = getAmodeRep amode
 120         ret_reg = dataReturnConvPrim kind
 121
 122         assign_possibly = case kind of
 123           VoidRep -> AbsCNop
 124           kind -> (CAssign (CReg ret_reg) amode)
 125     in
 126     performReturn assign_possibly (mkPrimReturnCode doc)
 127
 128 mkPrimReturnCode :: SDoc                -- Debugging only
 129                  -> Sequel
 130                  -> Code
 131 mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc
 132 mkPrimReturnCode doc sequel     = sequelToAmode sequel  `thenFC` \ dest_amode ->
 133                                   absC (CReturn dest_amode DirectReturn)
 134                                   -- Direct, no vectoring
 135
 136 -- Constructor is built on the heap; Node is set.
 137 -- All that remains is
 138 --      (a) to set TagReg, if necessary
 139 --      (c) to do the right sort of jump.
 140
 141 mkStaticAlgReturnCode :: DataCon        -- The constructor
 142                       -> Sequel         -- where to return to
 143                       -> Code
 144
 145 mkStaticAlgReturnCode con sequel
 146   =     -- Generate profiling code if necessary
 147     (case return_convention of
 148         VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz]
 149         other             -> nopC
 150     )                                   `thenC`
 151
 152         -- Set tag if necessary
 153         -- This is done by a macro, because if we are short of registers
 154         -- we don't set TagReg; instead the continuation gets the tag
 155         -- by indexing off the info ptr
 156     (case return_convention of
 157
 158         UnvectoredReturn no_of_constrs
 159          | no_of_constrs > 1
 160                 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
 161
 162         other   -> nopC
 163     )                                   `thenC`
 164
 165         -- Generate the right jump or return
 166     (case sequel of
 167         UpdateCode ->   -- Ha!  We can go direct to the update code,
 168                         -- (making sure to jump to the *correct* update
 169                         --  code.)
 170                         absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
 171                                       return_info)
 172
 173         CaseAlts _ (Just (alts, _)) ->  -- Ho! We know the constructor so
 174                                         -- we can go right to the alternative
 175
 176                 case assocMaybe alts tag of
 177                    Just (alt_absC, join_lbl) ->
 178                         absC (CJump (CLbl join_lbl CodePtrRep))
 179                    Nothing -> panic "mkStaticAlgReturnCode: default"
 180                                 -- The Nothing case should never happen;
 181                                 -- it's the subject of a wad of special-case
 182                                 -- code in cgReturnCon
 183
 184         -- can't be a SeqFrame, because we're returning a constructor
 185
 186         other ->        -- OnStack, or (CaseAlts ret_amode Nothing)
 187                     sequelToAmode sequel        `thenFC` \ ret_amode ->
 188                     absC (CReturn ret_amode return_info)
 189     )
 190
 191   where
 192     tag               = dataConTag   con
 193     tycon             = dataConTyCon con
 194     return_convention = ctrlReturnConvAlg tycon
 195     zero_indexed_tag  = tag - fIRST_TAG       -- Adjust tag to be zero-indexed
 196                                               -- cf AbsCUtils.mkAlgAltsCSwitch
 197
 198     return_info =
 199        case return_convention of
 200                 UnvectoredReturn _ -> DirectReturn
 201                 VectoredReturn _   -> StaticVectoredReturn zero_indexed_tag
 202
 203 mkUnboxedTupleReturnCode :: Sequel -> Code
 204 mkUnboxedTupleReturnCode sequel
 205     = case sequel of
 206         -- can't update with an unboxed tuple!
 207         UpdateCode -> panic "mkUnboxedTupleReturnCode"
 208
 209         CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) ->
 210                         absC (CJump (CLbl join_lbl CodePtrRep))
 211
 212         -- can't be a SeqFrame
 213
 214         other ->        -- OnStack, or (CaseAlts ret_amode something)
 215                     sequelToAmode sequel        `thenFC` \ ret_amode ->
 216                     absC (CReturn ret_amode DirectReturn)
 217
 218 -- This function is used by PrimOps that return enumerated types (i.e.
 219 -- all the comparison operators).
 220
 221 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
 222
 223 mkDynamicAlgReturnCode tycon dyn_tag sequel
 224   = case ctrlReturnConvAlg tycon of
 225         VectoredReturn sz ->
 226
 227                 profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
 228                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 229                 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
 230
 231         UnvectoredReturn no_of_constrs ->
 232
 233                 -- Set tag if necessary
 234                 -- This is done by a macro, because if we are short of registers
 235                 -- we don't set TagReg; instead the continuation gets the tag
 236                 -- by indexing off the info ptr
 237                 (if no_of_constrs > 1 then
 238                         absC (CMacroStmt SET_TAG [dyn_tag])
 239                 else
 240                         nopC
 241                 )                       `thenC`
 242
 243
 244                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 245                 -- Generate the right jump or return
 246                 absC (CReturn ret_addr DirectReturn)
 247 \end{code}
 248
 249 \begin{code}
 250 performReturn :: AbstractC          -- Simultaneous assignments to perform
 251               -> (Sequel -> Code)   -- The code to execute to actually do
 252                                     -- the return, given an addressing mode
 253                                     -- for the return address
 254               -> Code
 255
 256 -- this is just a special case of doTailCall, later.
 257 performReturn sim_assts finish_code
 258   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 259
 260         -- Do the simultaneous assignments,
 261     doSimAssts sim_assts                `thenC`
 262
 263         -- push a return address if necessary
 264         -- (after the assignments above, in case we clobber a live
 265         --  stack location)
 266     pushReturnAddress eob               `thenC`
 267
 268         -- Adjust Sp/Hp
 269     adjustSpAndHp args_sp               `thenC`
 270
 271         -- Do the return
 272     finish_code sequel          -- "sequel" is `robust' in that it doesn't
 273                                 -- depend on stk-ptr values
 274 \end{code}
 275
 276 Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
 277 we want to do things in a slightly different order to normal:
 278
 279                 - push return address
 280                 - adjust stack pointer
 281                 - r = call(args...)
 282                 - assign regs for unboxed tuple (usually just R1 = r)
 283                 - return to continuation
 284
 285 The return address (i.e. stack frame) must be on the stack before
 286 doing the call in case the call ends up in the garbage collector.
 287
 288 Sadly, the information about the continuation is lost after we push it
 289 (in order to avoid pushing it again), so we end up doing a needless
 290 indirect jump (ToDo).
 291
 292 \begin{code}
 293 returnUnboxedTuple :: [CAddrMode] -> Code -> Code
 294 returnUnboxedTuple amodes before_jump
 295   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 296
 297         -- push a return address if necessary
 298     pushReturnAddress eob               `thenC`
 299     setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
 300
 301         -- Adjust Sp/Hp
 302     adjustSpAndHp args_sp               `thenC`
 303
 304     before_jump                         `thenC`
 305
 306     let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
 307     in
 308
 309     profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
 310
 311     doTailCall amodes ret_regs
 312                 mkUnboxedTupleReturnCode
 313                 (length leftovers)  {- fast args arity -}
 314                 AbsCNop {-no pending assigments-}
 315                 Nothing {-not a let-no-escape-}
 316                 False   {-node doesn't point-}
 317      )
 318 \end{code}
 319
 320 \begin{code}
 321 performTailCall :: Id -> [StgArg] -> Code
 322 performTailCall fun args
 323   = getCAddrModeAndInfo fun                     `thenFC` \ (fun', fun_amode, lf_info) ->
 324     getArgAmodes args                           `thenFC` \ arg_amodes ->
 325     tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
 326 \end{code}
 327
 328 Generating code for a tail call to a function (or closure)
 329
 330 \begin{code}
 331 tailCallFun
 332          :: Id                          -- Function
 333          -> CAddrMode
 334          -> LambdaFormInfo
 335          -> [CAddrMode]                 -- Arguments
 336          -> AbstractC                   -- Pending simultaneous assignments
 337                                           -- *** GUARANTEED to contain only stack
 338                                           -- assignments.
 339                                         -- In ptic, we don't need to look in
 340                                         -- here to discover all live regs
 341          -> Code
 342
 343 tailCallFun fun fun_amode lf_info arg_amodes pending_assts
 344   = nodeMustPointToIt lf_info                   `thenFC` \ node_points ->
 345         -- we use the name of fun', the Id from the environment, rather than
 346         -- fun from the STG tree, in case it is a top-level name that we externalised
 347         -- (see cgTopRhsClosure).
 348     getEntryConvention (idName fun) lf_info
 349         (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
 350     let
 351         node_asst
 352           = if node_points then
 353                 CAssign (CReg node) fun_amode
 354             else
 355                 AbsCNop
 356
 357         (arg_regs, finish_code, arity)
 358           = case entry_conv of
 359               ViaNode ->
 360                 ([],
 361                      profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
 362                      absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
 363                                 [CVal (nodeRel 0) DataPtrRep]))
 364                      , 0)
 365               StdEntry lbl -> ([], absC (CJump (CLbl lbl CodePtrRep)), 0)
 366               DirectEntry lbl arity regs  ->
 367                 (regs,   absC (CJump (CLbl lbl CodePtrRep)),
 368                  arity - length regs)
 369
 370         -- set up for a let-no-escape if necessary
 371         join_sp = case fun_amode of
 372                         CJoinPoint sp -> Just sp
 373                         other         -> Nothing
 374     in
 375     doTailCall arg_amodes arg_regs (const finish_code) arity
 376                 (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
 377
 378
 379 -- this generic tail call code is used for both function calls and returns.
 380
 381 doTailCall
 382         :: [CAddrMode]                  -- args to pass to function
 383         -> [MagicId]                    -- registers to use
 384         -> (Sequel->Code)               -- code to perform jump
 385         -> Int                          -- number of "fast" stack arguments
 386         -> AbstractC                    -- pending assignments
 387         -> Maybe VirtualSpOffset        -- sp offset to trim stack to:
 388                                         -- USED iff destination is a let-no-escape
 389         -> Bool                         -- node points to the closure to enter
 390         -> Code
 391
 392 doTailCall arg_amodes arg_regs finish_code arity pending_assts
 393                 maybe_join_sp node_points
 394   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 395
 396     let
 397         (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs arg_amodes
 398             -- We get some stk_arg_amodes if (a) no regs, or
 399             --                               (b) args beyond arity
 400
 401         reg_arg_assts
 402           = mkAbstractCs (zipWithEqual "assign_to_reg2"
 403                                 assign_to_reg arg_regs reg_arg_amodes)
 404
 405         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 406
 407         join_sp = case maybe_join_sp of
 408                         Just sp -> ASSERT(not (args_sp > sp)) sp
 409               -- If ASSERTion fails: Oops: the join point has *lower*
 410               -- stack ptrs than the continuation Note that we take
 411               -- the Sp point without the return address here.   The
 412               -- return address is put on by the let-no-escapey thing
 413               -- when it finishes.
 414                         Nothing -> args_sp
 415
 416         (fast_stk_amodes, tagged_stk_amodes) =
 417                 splitAt arity stk_arg_amodes
 418
 419         -- eager blackholing, at the end of the basic block.
 420         (r1_tmp_asst, bh_asst)
 421          = case sequel of
 422 #if 0
 423         -- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
 424         -- we might be in a case continuation later down the line.  Also,
 425         -- we might have pushed a return address on the stack, if we're in
 426         -- a case scrut, and still be in the thunk's entry code.
 427                 UpdateCode ->
 428                    (CAssign node_save nodeReg,
 429                     CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep)
 430                                   PtrRep)
 431                             (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
 432                    where
 433                      node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
 434 #endif
 435                 _ -> (AbsCNop, AbsCNop)
 436     in
 437         -- We can omit tags on the arguments passed to the fast entry point,
 438         -- but we have to be careful to fill in the tags on any *extra*
 439         -- arguments we're about to push on the stack.
 440
 441         mkTaggedStkAmodes join_sp tagged_stk_amodes `thenFC`
 442                             \ (fast_sp, tagged_arg_assts, tag_assts) ->
 443
 444         mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
 445                             \ (final_sp, fast_arg_assts, _) ->
 446
 447         -- adjust the high-water mark if necessary
 448         adjustStackHW final_sp  `thenC`
 449
 450                 -- The stack space for the pushed return addess,
 451                 -- with any args pushed on top, is recorded in final_sp.
 452
 453                         -- Do the simultaneous assignments,
 454         doSimAssts (mkAbstractCs [r1_tmp_asst,
 455                                   pending_assts,
 456                                   reg_arg_assts,
 457                                   fast_arg_assts,
 458                                   tagged_arg_assts,
 459                                   tag_assts])   `thenC`
 460         absC bh_asst `thenC`
 461
 462                 -- push a return address if necessary
 463                 -- (after the assignments above, in case we clobber a live
 464                 --  stack location)
 465
 466                 -- DONT push the return address when we're about
 467                 -- to jump to a let-no-escape: the final tail call
 468                 -- in the let-no-escape will do this.
 469         (if (maybeToBool maybe_join_sp)
 470                 then nopC
 471                 else pushReturnAddress eob)             `thenC`
 472
 473                 -- Final adjustment of Sp/Hp
 474         adjustSpAndHp final_sp          `thenC`
 475
 476                 -- Now decide about semi-tagging
 477         let
 478                 semi_tagging_on = opt_DoSemiTagging
 479         in
 480         case (semi_tagging_on, arg_amodes, node_points, sequel) of
 481
 482         --
 483         -- *************** The semi-tagging case ***************
 484         --
 485         {- XXX leave this out for now.
 486               (   True,            [],          True,        CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
 487
 488                 -- Whoppee!  Semi-tagging rules OK!
 489                 -- (a) semi-tagging is switched on
 490                 -- (b) there are no arguments,
 491                 -- (c) Node points to the closure
 492                 -- (d) we have a case-alternative sequel with
 493                 --      some visible alternatives
 494
 495                 -- Why is test (c) necessary?
 496                 -- Usually Node will point to it at this point, because we're
 497                 -- scrutinsing something which is either a thunk or a
 498                 -- constructor.
 499                 -- But not always!  The example I came across is when we have
 500                 -- a top-level Double:
 501                 --      lit.3 = D# 3.000
 502                 --      ... (case lit.3 of ...) ...
 503                 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
 504                 -- (OK, the simplifier should have eliminated this, but it's
 505                 --  easy to deal with the case anyway.)
 506                 let
 507                     join_details_to_code (load_regs_and_profiling_code, join_lbl)
 508                         = load_regs_and_profiling_code          `mkAbsCStmts`
 509                           CJump (CLbl join_lbl CodePtrRep)
 510
 511                     semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
 512                                           join_details_to_code join_details)
 513                                        | (tag, join_details) <- st_alts
 514                                        ]
 515
 516                     enter_jump
 517                       -- Enter Node (we know infoptr will have the info ptr in it)!
 518                       = mkAbstractCs [
 519                         CCallProfCtrMacro FSLIT("RET_SEMI_FAILED")
 520                                         [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
 521                         CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
 522                 in
 523                         -- Final switch
 524                 absC (mkAbstractCs [
 525                             CAssign (CReg infoptr)
 526                                     (CVal (NodeRel zeroOff) DataPtrRep),
 527
 528                             case maybe_deflt_join_details of
 529                                 Nothing ->
 530                                     CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 531                                         (semi_tagged_alts)
 532                                         (enter_jump)
 533                                 Just (_, details) ->
 534                                     CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
 535                                      [(mkMachInt 0, enter_jump)]
 536                                      (CSwitch
 537                                          (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 538                                          (semi_tagged_alts)
 539                                          (join_details_to_code details))
 540                 ])
 541                 -}
 542
 543         --
 544         -- *************** The non-semi-tagging case ***************
 545         --
 546               other -> finish_code sequel
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection[tailCallPrimOp]{@tailCallPrimOp@}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 \begin{code}
 556 tailCallPrimOp :: PrimOp -> [StgArg] -> Code
 557 tailCallPrimOp op args =
 558     -- we're going to perform a normal-looking tail call,
 559     -- except that *all* the arguments will be in registers.
 560     getArgAmodes args           `thenFC` \ arg_amodes ->
 561     let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
 562     in
 563     ASSERT(null leftovers) -- no stack-resident args
 564     doTailCall arg_amodes arg_regs
 565         (const (absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))))
 566         0       {- arity shouldn't matter, all args in regs -}
 567         AbsCNop {- no pending assignments -}
 568         Nothing {- not a let-no-escape -}
 569         False   {- node doesn't point -}
 570 \end{code}
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection[doSimAssts]{@doSimAssts@}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 @doSimAssts@ happens at the end of every block of code.
 579 They are separate because we sometimes do some jiggery-pokery in between.
 580
 581 \begin{code}
 582 doSimAssts :: AbstractC -> Code
 583
 584 doSimAssts sim_assts
 585   = absC (CSimultaneous sim_assts)
 586 \end{code}
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection[retAddr]{@Return Addresses@}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 We always push the return address just before performing a tail call
 595 or return.  The reason we leave it until then is because the stack
 596 slot that the return address is to go into might contain something
 597 useful.
 598
 599 If the end of block info is CaseAlts, then we're in the scrutinee of a
 600 case expression and the return address is still to be pushed.
 601
 602 There are cases where it doesn't look necessary to push the return
 603 address: for example, just before doing a return to a known
 604 continuation.  However, the continuation will expect to find the
 605 return address on the stack in case it needs to do a heap check.
 606
 607 \begin{code}
 608 pushReturnAddress :: EndOfBlockInfo -> Code
 609 pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _)) =
 610     getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 611     absC (CAssign (CVal sp_rel RetRep) amode)
 612 pushReturnAddress (EndOfBlockInfo args_sp sequel@(SeqFrame amode _)) =
 613     pushSeqFrame args_sp                         `thenFC` \ ret_sp ->
 614     getSpRelOffset ret_sp                        `thenFC` \ sp_rel ->
 615     absC (CAssign (CVal sp_rel RetRep) amode)
 616 pushReturnAddress _ = nopC
 617 \end{code}