ghc/compiler/codeGen/CgTailCall.lhs

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