ghc/compiler/codeGen/CgTailCall.lhs

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