ghc/compiler/codeGen/CgTailCall.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgTailCall.lhs,v 1.38 2003/06/02 13:27:34 simonpj Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgTailCall]{Tail calls: converting @StgApps@}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgTailCall (
  14         cgTailCall, performTailCall,
  15         performReturn, performPrimReturn,
  16         mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
  17         returnUnboxedTuple, ccallReturnUnboxedTuple,
  18         mkPrimReturnCode,
  19         tailCallPrimOp,
  20
  21         pushReturnAddress
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 import CgMonad
  27 import CgBindery        ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
  28 import CgRetConv
  29 import CgStackery
  30 import CgUsages         ( getSpRelOffset, adjustSpAndHp )
  31 import ClosureInfo
  32
  33 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  34 import AbsCSyn
  35 import CLabel           ( mkRtsPrimOpLabel, mkSeqInfoLabel )
  36
  37 import Id               ( Id, idType, idName )
  38 import DataCon          ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
  39 import PrimRep          ( PrimRep(..) )
  40 import StgSyn           ( StgArg )
  41 import Type             ( isUnLiftedType )
  42 import Name             ( Name )
  43 import TyCon            ( TyCon )
  44 import PrimOp           ( PrimOp )
  45 import Util             ( zipWithEqual, splitAtList )
  46 import ListSetOps       ( assocMaybe )
  47 import PrimRep          ( isFollowableRep )
  48 import Outputable
  49 import Panic            ( panic, assertPanic )
  50
  51 import List             ( partition )
  52
  53 -----------------------------------------------------------------------------
  54 -- Tail Calls
  55
  56 cgTailCall :: Id -> [StgArg] -> Code
  57
  58 -- Here's the code we generate for a tail call.  (NB there may be no
  59 -- arguments, in which case this boils down to just entering a variable.)
  60 --
  61 --    * Put args in the top locations of the stack.
  62 --    * Adjust the stack ptr
  63 --    * Make R1 point to the function closure if necessary.
  64 --    * Perform the call.
  65 --
  66 -- Things to be careful about:
  67 --
  68 --    * Don't overwrite stack locations before you have finished with
  69 --      them (remember you need the function and the as-yet-unmoved
  70 --      arguments).
  71 --    * Preferably, generate no code to replace x by x on the stack (a
  72 --      common situation in tail-recursion).
  73 --    * Adjust the stack high water mark appropriately.
  74 --
  75 -- Treat unboxed locals exactly like literals (above) except use the addr
  76 -- mode for the local instead of (CLit lit) in the assignment.
  77
  78 -- Case for unboxed returns first:
  79 cgTailCall fun []
  80   | isUnLiftedType (idType fun)
  81   = getCAddrMode fun            `thenFC` \ amode ->
  82     performPrimReturn (ppr fun) amode
  83
  84 -- The general case (@fun@ is boxed):
  85 cgTailCall fun args
  86   = getCAddrModeAndInfo fun             `thenFC` \ (fun', fun_amode, lf_info) ->
  87     getArgAmodes args                   `thenFC` \ arg_amodes ->
  88     performTailCall fun' fun_amode lf_info arg_amodes AbsCNop
  89
  90
  91 -- -----------------------------------------------------------------------------
  92 -- The guts of a tail-call
  93
  94 performTailCall
  95         :: Id           -- function
  96         -> CAddrMode    -- function amode
  97         -> LambdaFormInfo
  98         -> [CAddrMode]
  99         -> AbstractC    -- Pending simultaneous assignments
 100                         -- *** GUARANTEED to contain only stack assignments.
 101         -> Code
 102
 103 performTailCall fun fun_amode lf_info arg_amodes pending_assts =
 104     nodeMustPointToIt lf_info           `thenFC` \ node_points ->
 105     let
 106         -- assign to node if necessary
 107         node_asst
 108            | node_points = CAssign (CReg node) fun_amode
 109            | otherwise   = AbsCNop
 110     in
 111
 112     getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 113
 114     let
 115         -- set up for a let-no-escape if necessary
 116         join_sp = case fun_amode of
 117                         CJoinPoint sp -> sp
 118                         other         -> args_sp
 119     in
 120
 121     -- decide how to code the tail-call: which registers assignments to make,
 122     -- what args to push on the stack, and how to make the jump
 123     constructTailCall (idName fun) lf_info arg_amodes join_sp
 124         node_points fun_amode sequel
 125                 `thenFC` \ (final_sp, arg_assts, jump_code) ->
 126
 127     let sim_assts = mkAbstractCs [node_asst,
 128                                   pending_assts,
 129                                   arg_assts]
 130
 131         is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False }
 132     in
 133
 134     doFinalJump final_sp sim_assts is_lne (const jump_code)
 135
 136
 137 -- Figure out how to do a particular tail-call.
 138
 139 constructTailCall
 140         :: Name
 141         -> LambdaFormInfo
 142         -> [CAddrMode]
 143         -> VirtualSpOffset              -- Sp at which to make the call
 144         -> Bool                         -- node points to the fun closure?
 145         -> CAddrMode                    -- addressing mode of the function
 146         -> Sequel                       -- the sequel, in case we need it
 147         -> FCode (
 148                 VirtualSpOffset,        -- Sp after pushing the args
 149                 AbstractC,              -- assignments
 150                 Code                    -- code to do the jump
 151            )
 152
 153 constructTailCall name lf_info arg_amodes sp node_points fun_amode sequel =
 154
 155     getEntryConvention name lf_info (map getAmodeRep arg_amodes)
 156                 `thenFC` \ entry_conv ->
 157
 158     case entry_conv of
 159         EnterIt -> returnFC (sp, AbsCNop, code)
 160           where code = profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
 161                        absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
 162                                 [CVal (nodeRel 0) DataPtrRep]))
 163
 164         -- A function, but we have zero arguments.  It is already in WHNF,
 165         -- so we can just return it.
 166         ReturnIt -> returnFC (sp, asst, code)
 167           where -- if node doesn't already point to the closure, we have to
 168                 -- load it up.
 169                 asst | node_points = AbsCNop
 170                      | otherwise   = CAssign (CReg node) fun_amode
 171
 172                 code = sequelToAmode sequel     `thenFC` \ dest_amode ->
 173                        absC (CReturn dest_amode DirectReturn)
 174
 175         JumpToIt lbl -> returnFC (sp, AbsCNop, code)
 176           where code = absC (CJump (CLbl lbl CodePtrRep))
 177
 178         -- a slow function call via the RTS apply routines
 179         SlowCall ->
 180                 let (apply_fn, new_amodes) = constructSlowCall arg_amodes
 181
 182                         -- if node doesn't already point to the closure,
 183                         -- we have to load it up.
 184                     node_asst | node_points = AbsCNop
 185                               | otherwise   = CAssign (CReg node) fun_amode
 186                 in
 187
 188                 -- Fill in all the arguments on the stack
 189                 mkStkAmodes sp new_amodes `thenFC`
 190                         \ (final_sp, stk_assts) ->
 191
 192                 returnFC
 193                   (final_sp + 1,   -- add one, because the stg_ap functions
 194                                    -- expect there to be a free slot on the stk
 195                    mkAbstractCs [node_asst, stk_assts],
 196                    absC (CJump apply_fn)
 197                   )
 198
 199         -- A direct function call (possibly with some left-over arguments)
 200         DirectEntry lbl arity regs
 201
 202            -- A let-no-escape is slightly different, because we
 203            -- arrange the stack arguments into pointers and non-pointers
 204            -- to make the heap check easier.  The tail-call sequence
 205            -- is very similar to returning an unboxed tuple, so we
 206            -- share some code.
 207            | is_let_no_escape ->
 208             pushUnboxedTuple sp arg_amodes   `thenFC` \ (final_sp, assts) ->
 209             returnFC (final_sp, assts, absC (CJump (CLbl lbl CodePtrRep)))
 210
 211
 212            -- A normal fast call
 213            | otherwise ->
 214            let
 215                 -- first chunk of args go in registers
 216                 (reg_arg_amodes, stk_arg_amodes) =
 217                     splitAtList regs arg_amodes
 218
 219                 -- the rest of this function's args go straight on the stack
 220                 (stk_args, extra_stk_args) =
 221                     splitAt (arity - length regs) stk_arg_amodes
 222
 223                 -- any "extra" arguments are placed in frames on the
 224                 -- stack after the other arguments.
 225                 slow_stk_args = slowArgs extra_stk_args
 226
 227                 reg_assts
 228                     = mkAbstractCs (zipWithEqual "assign_to_reg2"
 229                                         assign_to_reg regs reg_arg_amodes)
 230
 231             in
 232             mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC`
 233                         \ (final_sp, stk_assts) ->
 234
 235             returnFC
 236                 (final_sp,
 237                  mkAbstractCs [reg_assts, stk_assts],
 238                  absC (CJump (CLbl lbl CodePtrRep))
 239                 )
 240
 241        where is_let_no_escape = case fun_amode of
 242                                         CJoinPoint _ -> True
 243                                         _ -> False
 244
 245 -- -----------------------------------------------------------------------------
 246 -- The final clean-up before we do a jump at the end of a basic block.
 247 -- This code is shared by tail-calls and returns.
 248
 249 doFinalJump :: VirtualSpOffset -> AbstractC -> Bool -> (Sequel -> Code) -> Code
 250 doFinalJump final_sp sim_assts is_let_no_escape jump_code =
 251
 252     -- adjust the high-water mark if necessary
 253     adjustStackHW final_sp      `thenC`
 254
 255     -- Do the simultaneous assignments,
 256     absC (CSimultaneous sim_assts) `thenC`
 257
 258         -- push a return address if necessary (after the assignments
 259         -- above, in case we clobber a live stack location)
 260         --
 261         -- DONT push the return address when we're about to jump to a
 262         -- let-no-escape: the final tail call in the let-no-escape
 263         -- will do this.
 264     getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 265     (if is_let_no_escape then nopC
 266                          else pushReturnAddress eob)    `thenC`
 267
 268     -- Final adjustment of Sp/Hp
 269     adjustSpAndHp final_sp              `thenC`
 270
 271     -- and do the jump
 272     jump_code sequel
 273
 274 -- -----------------------------------------------------------------------------
 275 -- A general return (just a special case of doFinalJump, above)
 276
 277 performReturn :: AbstractC          -- Simultaneous assignments to perform
 278               -> (Sequel -> Code)   -- The code to execute to actually do
 279                                     -- the return, given an addressing mode
 280                                     -- for the return address
 281               -> Code
 282
 283 performReturn sim_assts finish_code
 284   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 285     doFinalJump args_sp sim_assts False{-not a LNE-} finish_code
 286
 287 -- -----------------------------------------------------------------------------
 288 -- Primitive Returns
 289
 290 -- Just load the return value into the right register, and return.
 291
 292 performPrimReturn :: SDoc       -- Just for debugging (sigh)
 293                   -> CAddrMode  -- The thing to return
 294                   -> Code
 295
 296 performPrimReturn doc amode
 297   = let
 298         kind = getAmodeRep amode
 299         ret_reg = dataReturnConvPrim kind
 300
 301         assign_possibly = case kind of
 302                                 VoidRep -> AbsCNop
 303                                 kind -> (CAssign (CReg ret_reg) amode)
 304     in
 305     performReturn assign_possibly (mkPrimReturnCode doc)
 306
 307 mkPrimReturnCode :: SDoc                -- Debugging only
 308                  -> Sequel
 309                  -> Code
 310 mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc
 311 mkPrimReturnCode doc sequel     = sequelToAmode sequel  `thenFC` \ dest_amode ->
 312                                   absC (CReturn dest_amode DirectReturn)
 313                                   -- Direct, no vectoring
 314
 315 -- -----------------------------------------------------------------------------
 316 -- Algebraic constructor returns
 317
 318 -- Constructor is built on the heap; Node is set.
 319 -- All that remains is
 320 --      (a) to set TagReg, if necessary
 321 --      (c) to do the right sort of jump.
 322
 323 mkStaticAlgReturnCode :: DataCon        -- The constructor
 324                       -> Sequel         -- where to return to
 325                       -> Code
 326
 327 mkStaticAlgReturnCode con sequel
 328   =     -- Generate profiling code if necessary
 329     (case return_convention of
 330         VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz]
 331         other             -> nopC
 332     )                                   `thenC`
 333
 334         -- Set tag if necessary
 335         -- This is done by a macro, because if we are short of registers
 336         -- we don't set TagReg; instead the continuation gets the tag
 337         -- by indexing off the info ptr
 338     (case return_convention of
 339
 340         UnvectoredReturn no_of_constrs
 341          | no_of_constrs > 1
 342                 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
 343
 344         other   -> nopC
 345     )                                   `thenC`
 346
 347         -- Generate the right jump or return
 348     (case sequel of
 349         CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so
 350                                         -- we can go right to the alternative
 351
 352                 case assocMaybe alts tag of
 353                    Just (alt_absC, join_lbl) ->
 354                         absC (CJump (CLbl join_lbl CodePtrRep))
 355                    Nothing -> panic "mkStaticAlgReturnCode: default"
 356                                 -- The Nothing case should never happen;
 357                                 -- it's the subject of a wad of special-case
 358                                 -- code in cgReturnCon
 359
 360         other ->        -- OnStack, or (CaseAlts ret_amode Nothing),
 361                         -- or UpdateCode.
 362                     sequelToAmode sequel        `thenFC` \ ret_amode ->
 363                     absC (CReturn ret_amode return_info)
 364     )
 365
 366   where
 367     tag               = dataConTag   con
 368     tycon             = dataConTyCon con
 369     return_convention = ctrlReturnConvAlg tycon
 370     zero_indexed_tag  = tag - fIRST_TAG       -- Adjust tag to be zero-indexed
 371                                               -- cf AbsCUtils.mkAlgAltsCSwitch
 372
 373     return_info =
 374        case return_convention of
 375                 UnvectoredReturn _ -> DirectReturn
 376                 VectoredReturn _   -> StaticVectoredReturn zero_indexed_tag
 377
 378
 379 -- -----------------------------------------------------------------------------
 380 -- Returning an enumerated type from a PrimOp
 381
 382 -- This function is used by PrimOps that return enumerated types (i.e.
 383 -- all the comparison operators).
 384
 385 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
 386
 387 mkDynamicAlgReturnCode tycon dyn_tag sequel
 388   = case ctrlReturnConvAlg tycon of
 389         VectoredReturn sz ->
 390
 391                 profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
 392                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 393                 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
 394
 395         UnvectoredReturn no_of_constrs ->
 396
 397                 -- Set tag if necessary
 398                 -- This is done by a macro, because if we are short of registers
 399                 -- we don't set TagReg; instead the continuation gets the tag
 400                 -- by indexing off the info ptr
 401                 (if no_of_constrs > 1 then
 402                         absC (CMacroStmt SET_TAG [dyn_tag])
 403                 else
 404                         nopC
 405                 )                       `thenC`
 406
 407
 408                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 409                 -- Generate the right jump or return
 410                 absC (CReturn ret_addr DirectReturn)
 411
 412
 413 -- ---------------------------------------------------------------------------
 414 -- Unboxed tuple returns
 415
 416 -- These are a bit like a normal tail call, except that:
 417 --
 418 --   - The tail-call target is an info table on the stack
 419 --
 420 --   - We separate stack arguments into pointers and non-pointers,
 421 --     to make it easier to leave things in a sane state for a heap check.
 422 --     This is OK because we can never partially-apply an unboxed tuple,
 423 --     unlike a function.  The same technique is used when calling
 424 --     let-no-escape functions, because they also can't be partially
 425 --     applied.
 426
 427 returnUnboxedTuple :: [CAddrMode] -> Code
 428 returnUnboxedTuple amodes =
 429     getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 430
 431     profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
 432
 433     pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) ->
 434     doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode
 435
 436
 437 pushUnboxedTuple
 438         :: VirtualSpOffset              -- Sp at which to start pushing
 439         -> [CAddrMode]                  -- amodes of the components
 440         -> FCode (VirtualSpOffset,      -- final Sp
 441                   AbstractC)            -- assignments (regs+stack)
 442
 443 pushUnboxedTuple sp amodes =
 444     let
 445         (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes)
 446
 447         (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes
 448
 449         -- separate the rest of the args into pointers and non-pointers
 450         ( ptr_args, nptr_args ) =
 451            partition (isFollowableRep . getAmodeRep) stk_arg_amodes
 452
 453         reg_arg_assts
 454           = mkAbstractCs (zipWithEqual "assign_to_reg2"
 455                                 assign_to_reg arg_regs reg_arg_amodes)
 456     in
 457
 458     -- push ptrs, then nonptrs, on the stack
 459     mkStkAmodes sp ptr_args       `thenFC` \ (ptr_sp,  ptr_assts) ->
 460     mkStkAmodes ptr_sp  nptr_args `thenFC` \ (final_sp, nptr_assts) ->
 461
 462     returnFC (final_sp,
 463               mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts])
 464
 465
 466
 467 mkUnboxedTupleReturnCode :: Sequel -> Code
 468 mkUnboxedTupleReturnCode sequel
 469     = case sequel of
 470         -- can't update with an unboxed tuple!
 471         UpdateCode -> panic "mkUnboxedTupleReturnCode"
 472
 473         CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False ->
 474                         absC (CJump (CLbl join_lbl CodePtrRep))
 475
 476         other ->        -- OnStack, or (CaseAlts ret_amode something)
 477                     sequelToAmode sequel        `thenFC` \ ret_amode ->
 478                     absC (CReturn ret_amode DirectReturn)
 479
 480 -- -----------------------------------------------------------------------------
 481 -- Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
 482 -- we want to do things in a slightly different order to normal:
 483 --
 484 --              - push return address
 485 --              - adjust stack pointer
 486 --              - r = call(args...)
 487 --              - assign regs for unboxed tuple (usually just R1 = r)
 488 --              - return to continuation
 489 --
 490 -- The return address (i.e. stack frame) must be on the stack before
 491 -- doing the call in case the call ends up in the garbage collector.
 492 --
 493 -- Sadly, the information about the continuation is lost after we push it
 494 -- (in order to avoid pushing it again), so we end up doing a needless
 495 -- indirect jump (ToDo).
 496
 497 ccallReturnUnboxedTuple :: [CAddrMode] -> Code -> Code
 498 ccallReturnUnboxedTuple amodes before_jump
 499   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 500
 501         -- push a return address if necessary
 502     pushReturnAddress eob               `thenC`
 503     setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
 504
 505         -- Adjust Sp/Hp
 506     adjustSpAndHp args_sp               `thenC`
 507
 508     before_jump                         `thenC`
 509
 510     returnUnboxedTuple amodes
 511   )
 512
 513 -- -----------------------------------------------------------------------------
 514 -- Calling an out-of-line primop
 515
 516 tailCallPrimOp :: PrimOp -> [StgArg] -> Code
 517 tailCallPrimOp op args =
 518     -- we're going to perform a normal-looking tail call,
 519     -- except that *all* the arguments will be in registers.
 520     getArgAmodes args           `thenFC` \ arg_amodes ->
 521     let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
 522
 523         reg_arg_assts
 524           = mkAbstractCs (zipWithEqual "assign_to_reg2"
 525                                 assign_to_reg arg_regs arg_amodes)
 526
 527         jump_to_primop =
 528            absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))
 529     in
 530
 531     ASSERT(null leftovers) -- no stack-resident args
 532
 533     getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 534     doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop)
 535
 536 -- -----------------------------------------------------------------------------
 537 -- Return Addresses
 538
 539 -- | We always push the return address just before performing a tail call
 540 -- or return.  The reason we leave it until then is because the stack
 541 -- slot that the return address is to go into might contain something
 542 -- useful.
 543 --
 544 -- If the end of block info is 'CaseAlts', then we're in the scrutinee of a
 545 -- case expression and the return address is still to be pushed.
 546 --
 547 -- There are cases where it doesn't look necessary to push the return
 548 -- address: for example, just before doing a return to a known
 549 -- continuation.  However, the continuation will expect to find the
 550 -- return address on the stack in case it needs to do a heap check.
 551
 552 pushReturnAddress :: EndOfBlockInfo -> Code
 553
 554 pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) =
 555     getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 556     absC (CAssign (CVal sp_rel RetRep) amode)
 557
 558 -- For a polymorphic case, we have two return addresses to push: the case
 559 -- return, and stg_seq_frame_info which turns a possible vectored return
 560 -- into a direct one.
 561 pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ True)) =
 562     getSpRelOffset (args_sp-1)                   `thenFC` \ sp_rel ->
 563     absC (CAssign (CVal sp_rel RetRep) amode)    `thenC`
 564     getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
 565     absC (CAssign (CVal sp_rel RetRep) (CLbl mkSeqInfoLabel RetRep))
 566 pushReturnAddress _ = nopC
 567
 568 -- -----------------------------------------------------------------------------
 569 -- Misc.
 570
 571 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 572
 573 \end{code}