ghc/compiler/codeGen/CgTailCall.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %********************************************************
   5 %*                                                      *
   6 \section[CgTailCall]{Tail calls: converting @StgApps@}
   7 %*                                                      *
   8 %********************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module CgTailCall (
  14         cgTailCall,
  15         performReturn,
  16         mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
  17         mkPrimReturnCode,
  18
  19         tailCallBusiness
  20
  21         -- and to make the interface self-sufficient...
  22     ) where
  23
  24 IMPORT_Trace
  25 import Pretty           -- Pretty/Outputable: rm (debugging only) ToDo
  26 import Outputable
  27
  28 import StgSyn
  29 import CgMonad
  30 import AbsCSyn
  31
  32 import Type             ( isPrimType, Type )
  33 import CgBindery        ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
  34 import CgCompInfo       ( oTHER_TAG, iND_TAG )
  35 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
  36                           mkLiveRegsBitMask,
  37                           CtrlReturnConvention(..), DataReturnConvention(..)
  38                         )
  39 import CgStackery       ( adjustRealSps, mkStkAmodes )
  40 import CgUsages         ( getSpARelOffset, getSpBRelOffset )
  41 import CLabel   ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
  42 import ClosureInfo      ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
  43 import CmdLineOpts      ( GlobalSwitch(..) )
  44 import Id               ( getDataConTyCon, getDataConTag,
  45                           idType, getIdPrimRep, fIRST_TAG, Id,
  46                           ConTag(..)
  47                         )
  48 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
  49 import PrimRep          ( retPrimRepSize )
  50 import Util
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[tailcall-doc]{Documentation}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
  61 \end{code}
  62
  63 Here's the code we generate for a tail call.  (NB there may be no
  64 arguments, in which case this boils down to just entering a variable.)
  65
  66 \begin{itemize}
  67 \item   Adjust the stack ptr to \tr{tailSp + #args}.
  68 \item   Put args in the top locations of the resulting stack.
  69 \item   Make Node point to the function closure.
  70 \item   Enter the function closure.
  71 \end{itemize}
  72
  73 Things to be careful about:
  74 \begin{itemize}
  75 \item   Don't overwrite stack locations before you have finished with
  76         them (remember you need the function and the as-yet-unmoved
  77         arguments).
  78 \item   Preferably, generate no code to replace x by x on the stack (a
  79         common situation in tail-recursion).
  80 \item   Adjust the stack high water mark appropriately.
  81 \end{itemize}
  82
  83 Literals are similar to constructors; they return by putting
  84 themselves in an appropriate register and returning to the address on
  85 top of the B stack.
  86
  87 \begin{code}
  88 cgTailCall (StgLitArg lit) [] live_vars
  89   = performPrimReturn (CLit lit) live_vars
  90 \end{code}
  91
  92 Treat unboxed locals exactly like literals (above) except use the addr
  93 mode for the local instead of (CLit lit) in the assignment.
  94
  95 Case for unboxed @Ids@ first:
  96 \begin{code}
  97 cgTailCall atom@(StgVarArg fun) [] live_vars
  98   | isPrimType (idType fun)
  99   = getCAddrMode fun `thenFC` \ amode ->
 100     performPrimReturn amode live_vars
 101 \end{code}
 102
 103 The general case (@fun@ is boxed):
 104 \begin{code}
 105 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
 106 \end{code}
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 \subsection[return-and-tail-call]{Return and tail call}
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 ADR-HACK
 115
 116   A quick bit of hacking to try to solve my void#-leaking blues...
 117
 118   I think I'm getting bitten by this stuff because code like
 119
 120   \begin{pseudocode}
 121           case ds.s12 :: IoWorld of {
 122               -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
 123             IoWorld ds.s13# -> ds.s13#;
 124           } :: Universe#
 125   \end{pseudocode}
 126
 127   causes me to try to allocate a register to return the result in.  The
 128   hope is that the following will avoid such problems (and that Will
 129   will do this in a cleaner way when he hits the same problem).
 130
 131 KCAH-RDA
 132
 133 \begin{code}
 134 performPrimReturn :: CAddrMode  -- The thing to return
 135                   -> StgLiveVars
 136                   -> Code
 137
 138 performPrimReturn amode live_vars
 139   = let
 140         kind = getAmodeRep amode
 141         ret_reg = dataReturnConvPrim kind
 142
 143         assign_possibly = case kind of
 144           VoidRep -> AbsCNop
 145           kind -> (CAssign (CReg ret_reg) amode)
 146     in
 147     performReturn assign_possibly mkPrimReturnCode live_vars
 148
 149 mkPrimReturnCode :: Sequel -> Code
 150 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
 151 mkPrimReturnCode sequel         = sequelToAmode sequel  `thenFC` \ dest_amode ->
 152                                   absC (CReturn dest_amode DirectReturn)
 153                                   -- Direct, no vectoring
 154
 155 -- All constructor arguments in registers; Node and InfoPtr are set.
 156 -- All that remains is
 157 --      (a) to set TagReg, if necessary
 158 --      (b) to set InfoPtr to the info ptr, if necessary
 159 --      (c) to do the right sort of jump.
 160
 161 mkStaticAlgReturnCode :: Id             -- The constructor
 162                       -> Maybe CLabel   -- The info ptr, if it isn't already set
 163                       -> Sequel         -- where to return to
 164                       -> Code
 165
 166 mkStaticAlgReturnCode con maybe_info_lbl sequel
 167   =     -- Generate profiling code if necessary
 168     (case return_convention of
 169         VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
 170         other             -> nopC
 171     )                                   `thenC`
 172
 173         -- Set tag if necessary
 174         -- This is done by a macro, because if we are short of registers
 175         -- we don't set TagReg; instead the continuation gets the tag
 176         -- by indexing off the info ptr
 177     (case return_convention of
 178
 179         UnvectoredReturn no_of_constrs
 180          | no_of_constrs > 1
 181                 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
 182
 183         other   -> nopC
 184     )                                   `thenC`
 185
 186         -- Generate the right jump or return
 187     (case sequel of
 188         UpdateCode _ -> -- Ha!  We know the constructor,
 189                         -- so we can go direct to the correct
 190                         -- update code for that constructor
 191
 192                                 -- Set the info pointer, and jump
 193                         set_info_ptr            `thenC`
 194                         getIntSwitchChkrC       `thenFC` \ isw_chkr ->
 195                         absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
 196
 197         CaseAlts _ (Just (alts, _)) ->  -- Ho! We know the constructor so
 198                                         -- we can go right to the alternative
 199
 200                         -- No need to set info ptr when returning to a
 201                         -- known join point. After all, the code at
 202                         -- the destination knows what constructor it
 203                         -- is going to handle.
 204
 205                         case assocMaybe alts tag of
 206                            Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
 207                            Nothing                   -> panic "mkStaticAlgReturnCode: default"
 208                                 -- The Nothing case should never happen; it's the subject
 209                                 -- of a wad of special-case code in cgReturnCon
 210
 211         other ->        -- OnStack, or (CaseAlts) ret_amode Nothing)
 212                         -- Set the info pointer, and jump
 213                     set_info_ptr                `thenC`
 214                     sequelToAmode sequel        `thenFC` \ ret_amode ->
 215                     absC (CReturn ret_amode return_info)
 216     )
 217
 218   where
 219     tag               = getDataConTag con
 220     tycon             = getDataConTyCon con
 221     return_convention = ctrlReturnConvAlg tycon
 222     zero_indexed_tag  = tag - fIRST_TAG       -- Adjust tag to be zero-indexed
 223                                               -- cf AbsCUtils.mkAlgAltsCSwitch
 224
 225     update_label isw_chkr
 226       = case (dataReturnConvAlg isw_chkr con) of
 227           ReturnInHeap   -> mkStdUpdCodePtrVecLabel tycon tag
 228           ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
 229
 230     return_info = case return_convention of
 231                         UnvectoredReturn _ -> DirectReturn
 232                         VectoredReturn _   -> StaticVectoredReturn zero_indexed_tag
 233
 234     set_info_ptr = case maybe_info_lbl of
 235                         Nothing       -> nopC
 236                         Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
 237
 238
 239 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
 240
 241 mkDynamicAlgReturnCode tycon dyn_tag sequel
 242   = case ctrlReturnConvAlg tycon of
 243         VectoredReturn sz ->
 244
 245                 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
 246                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 247                 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
 248
 249         UnvectoredReturn no_of_constrs ->
 250
 251                 -- Set tag if necessary
 252                 -- This is done by a macro, because if we are short of registers
 253                 -- we don't set TagReg; instead the continuation gets the tag
 254                 -- by indexing off the info ptr
 255                 (if no_of_constrs > 1 then
 256                         absC (CMacroStmt SET_TAG [dyn_tag])
 257                 else
 258                         nopC
 259                 )                       `thenC`
 260
 261
 262                 sequelToAmode sequel            `thenFC` \ ret_addr ->
 263                 -- Generate the right jump or return
 264                 absC (CReturn ret_addr DirectReturn)
 265 \end{code}
 266
 267 \begin{code}
 268 performReturn :: AbstractC          -- Simultaneous assignments to perform
 269               -> (Sequel -> Code)   -- The code to execute to actually do
 270                                     -- the return, given an addressing mode
 271                                     -- for the return address
 272               -> StgLiveVars
 273               -> Code
 274
 275 performReturn sim_assts finish_code live_vars
 276   = getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
 277
 278         -- Do the simultaneous assignments,
 279     doSimAssts args_spa live_vars sim_assts     `thenC`
 280
 281         -- Adjust stack pointers
 282     adjustRealSps args_spa args_spb     `thenC`
 283
 284         -- Do the return
 285     finish_code sequel          -- "sequel" is `robust' in that it doesn't
 286                                 -- depend on stk-ptr values
 287 \end{code}
 288
 289 \begin{code}
 290 performTailCall :: Id                   -- Function
 291                 -> [StgArg]     -- Args
 292                 -> StgLiveVars
 293                 -> Code
 294
 295 performTailCall fun args live_vars
 296   =     -- Get all the info we have about the function and args and go on to
 297         -- the business end
 298     getCAddrModeAndInfo fun     `thenFC` \ (fun_amode, lf_info) ->
 299     getAtomAmodes args          `thenFC` \ arg_amodes ->
 300
 301     tailCallBusiness
 302                 fun fun_amode lf_info arg_amodes
 303                 live_vars AbsCNop {- No pending assignments -}
 304
 305
 306 tailCallBusiness :: Id -> CAddrMode     -- Function and its amode
 307                  -> LambdaFormInfo      -- Info about the function
 308                  -> [CAddrMode]         -- Arguments
 309                  -> StgLiveVars -- Live in continuation
 310
 311                  -> AbstractC           -- Pending simultaneous assignments
 312                                         -- *** GUARANTEED to contain only stack assignments.
 313                                         --     In ptic, we don't need to look in here to
 314                                         --     discover all live regs
 315
 316                  -> Code
 317
 318 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 319   = isSwitchSetC EmitArityChecks                `thenFC` \ do_arity_chks ->
 320
 321     nodeMustPointToIt lf_info                   `thenFC` \ node_points ->
 322     getEntryConvention fun lf_info
 323         (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
 324
 325     getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
 326
 327     let
 328         node_asst
 329           = if node_points then
 330                 CAssign (CReg node) fun_amode
 331             else
 332                 AbsCNop
 333
 334         (arg_regs, finish_code)
 335           = case entry_conv of
 336               ViaNode                     ->
 337                 ([],
 338                      mkAbstractCs [
 339                         CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
 340                         CAssign (CReg infoptr)
 341
 342                                 (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
 343                         CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
 344                      ])
 345               StdEntry lbl Nothing        -> ([], CJump (CLbl lbl CodePtrRep))
 346               StdEntry lbl (Just itbl)    -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
 347                                                      `mkAbsCStmts`
 348                                                   CJump (CLbl lbl CodePtrRep))
 349               DirectEntry lbl arity regs  ->
 350                 (regs,   (if do_arity_chks
 351                           then CMacroStmt SET_ARITY [mkIntCLit arity]
 352                           else AbsCNop)
 353                          `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
 354
 355         no_of_args = length arg_amodes
 356
 357         (reg_arg_assts, stk_arg_amodes)
 358             = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
 359                         drop (length arg_regs) arg_amodes) -- No regs, or
 360                                                            -- args beyond arity
 361
 362         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 363     in
 364     case fun_amode of
 365       CJoinPoint join_spa join_spb ->  -- Ha!  A let-no-escape thingy
 366
 367           ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
 368               -- If ASSERTion fails: Oops: the join point has *lower*
 369               -- stack ptrs than the continuation Note that we take
 370               -- the SpB point without the return address here.  The
 371               -- return address is put on by the let-no-escapey thing
 372               -- when it finishes.
 373
 374           mkStkAmodes join_spa join_spb stk_arg_amodes
 375                       `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
 376
 377                 -- Do the simultaneous assignments,
 378           doSimAssts join_spa live_vars
 379                 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
 380                         `thenC`
 381
 382                 -- Adjust stack ptrs
 383           adjustRealSps final_spa final_spb     `thenC`
 384
 385                 -- Jump to join point
 386           absC finish_code
 387
 388       _ -> -- else: not a let-no-escape (the common case)
 389
 390                 -- Make instruction to save return address
 391             loadRetAddrIntoRetReg sequel        `thenFC` \ ret_asst ->
 392
 393             mkStkAmodes args_spa args_spb stk_arg_amodes
 394                                                 `thenFC`
 395                             \ (final_spa, final_spb, stk_arg_assts) ->
 396
 397                 -- The B-stack space for the pushed return addess, with any args pushed
 398                 -- on top, is recorded in final_spb.
 399
 400                 -- Do the simultaneous assignments,
 401             doSimAssts args_spa live_vars
 402                 (mkAbstractCs [pending_assts, node_asst, ret_asst,
 403                                reg_arg_assts, stk_arg_assts])
 404                                                 `thenC`
 405
 406                 -- Final adjustment of stack pointers
 407             adjustRealSps final_spa final_spb   `thenC`
 408
 409                 -- Now decide about semi-tagging
 410             isSwitchSetC DoSemiTagging          `thenFC` \ semi_tagging_on ->
 411             case (semi_tagging_on, arg_amodes, node_points, sequel) of
 412
 413         --
 414         -- *************** The semi-tagging case ***************
 415         --
 416               (   True,            [],          True,        CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
 417
 418                 -- Whoppee!  Semi-tagging rules OK!
 419                 -- (a) semi-tagging is switched on
 420                 -- (b) there are no arguments,
 421                 -- (c) Node points to the closure
 422                 -- (d) we have a case-alternative sequel with
 423                 --      some visible alternatives
 424
 425                 -- Why is test (c) necessary?
 426                 -- Usually Node will point to it at this point, because we're
 427                 -- scrutinsing something which is either a thunk or a
 428                 -- constructor.
 429                 -- But not always!  The example I came across is when we have
 430                 -- a top-level Double:
 431                 --      lit.3 = D# 3.000
 432                 --      ... (case lit.3 of ...) ...
 433                 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
 434                 -- (OK, the simplifier should have eliminated this, but it's
 435                 --  easy to deal with the case anyway.)
 436                 let
 437                     join_details_to_code (load_regs_and_profiling_code, join_lbl)
 438                         = load_regs_and_profiling_code          `mkAbsCStmts`
 439                           CJump (CLbl join_lbl CodePtrRep)
 440
 441                     semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
 442                                           join_details_to_code join_details)
 443                                        | (tag, join_details) <- st_alts
 444                                        ]
 445
 446                     enter_jump
 447                       -- Enter Node (we know infoptr will have the info ptr in it)!
 448                       = mkAbstractCs [
 449                         CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
 450                                         [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
 451                         CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
 452                 in
 453                         -- Final switch
 454                 absC (mkAbstractCs [
 455                             CAssign (CReg infoptr)
 456                                     (CVal (NodeRel zeroOff) DataPtrRep),
 457
 458                             case maybe_deflt_join_details of
 459                                 Nothing ->
 460                                     CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 461                                         (semi_tagged_alts)
 462                                         (enter_jump)
 463                                 Just (_, details) ->
 464                                     CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
 465                                      [(mkMachInt 0, enter_jump)]
 466                                      (CSwitch
 467                                          (CMacroExpr IntRep INFO_TAG [CReg infoptr])
 468                                          (semi_tagged_alts)
 469                                          (join_details_to_code details))
 470                 ])
 471
 472         --
 473         -- *************** The non-semi-tagging case ***************
 474         --
 475               other -> absC finish_code
 476 \end{code}
 477
 478 \begin{code}
 479 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
 480
 481 loadRetAddrIntoRetReg InRetReg
 482   = returnFC AbsCNop  -- Return address already there
 483
 484 loadRetAddrIntoRetReg sequel
 485   = sequelToAmode sequel      `thenFC` \ amode ->
 486     returnFC (CAssign (CReg RetReg) amode)
 487
 488 \end{code}
 489
 490 %************************************************************************
 491 %*                                                                      *
 492 \subsection[doSimAssts]{@doSimAssts@}
 493 %*                                                                      *
 494 %************************************************************************
 495
 496 @doSimAssts@ happens at the end of every block of code.
 497 They are separate because we sometimes do some jiggery-pokery in between.
 498
 499 \begin{code}
 500 doSimAssts :: VirtualSpAOffset  -- tail_spa: SpA as seen by continuation
 501            -> StgLiveVars       -- Live in continuation
 502            -> AbstractC
 503            -> Code
 504
 505 doSimAssts tail_spa live_vars sim_assts
 506   =     -- Do the simultaneous assignments
 507     absC (CSimultaneous sim_assts)      `thenC`
 508
 509         -- Stub any unstubbed slots; the only live variables are indicated in
 510         -- the end-of-block info in the monad
 511     nukeDeadBindings live_vars          `thenC`
 512     getUnstubbedAStackSlots tail_spa    `thenFC` \ a_slots ->
 513         -- Passing in tail_spa here should actually be redundant, because
 514         -- the stack should be trimmed (by nukeDeadBindings) to
 515         -- exactly the tail_spa position anyhow.
 516
 517         -- Emit code to stub dead regs; this only generates actual
 518         -- machine instructions in in the DEBUG version
 519         -- *** NOT DONE YET ***
 520
 521     (if (null a_slots)
 522      then nopC
 523      else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)]      `thenC`
 524           mapCs stub_A_slot a_slots
 525     )
 526   where
 527     stub_A_slot :: VirtualSpAOffset -> Code
 528     stub_A_slot offset = getSpARelOffset offset         `thenFC` \ spa_rel ->
 529                          absC (CAssign  (CVal spa_rel PtrRep)
 530                                         (CReg StkStubReg))
 531 \end{code}