ghc/compiler/codeGen/CgTailCall.lhs

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