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