2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %********************************************************
6 \section[CgTailCall]{Tail calls: converting @StgApps@}
8 %********************************************************
11 #include "HsVersions.h"
16 mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
27 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
28 import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
29 import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
30 ctrlReturnConvAlg, CtrlReturnConvention(..),
31 DataReturnConvention(..)
33 import CgStackery ( adjustRealSps, mkStkAmodes )
34 import CgUsages ( getSpARelOffset )
35 import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
36 import ClosureInfo ( nodeMustPointToIt,
37 getEntryConvention, EntryConvention(..),
40 import CmdLineOpts ( opt_DoSemiTagging )
41 import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) )
42 import Id ( idType, dataConTyCon, dataConTag,
45 import Literal ( mkMachInt )
46 import Maybes ( assocMaybe )
47 import PrimRep ( PrimRep(..) )
48 import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) )
49 import Type ( isPrimType )
50 import TyCon ( TyCon )
51 import Util ( zipWithEqual, panic, assertPanic )
54 %************************************************************************
56 \subsection[tailcall-doc]{Documentation}
58 %************************************************************************
61 cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
64 Here's the code we generate for a tail call. (NB there may be no
65 arguments, in which case this boils down to just entering a variable.)
68 \item Adjust the stack ptr to \tr{tailSp + #args}.
69 \item Put args in the top locations of the resulting stack.
70 \item Make Node point to the function closure.
71 \item Enter the function closure.
74 Things to be careful about:
76 \item Don't overwrite stack locations before you have finished with
77 them (remember you need the function and the as-yet-unmoved
79 \item Preferably, generate no code to replace x by x on the stack (a
80 common situation in tail-recursion).
81 \item Adjust the stack high water mark appropriately.
85 cgTailCall (StgConArg con) args live_vars
86 = panic "cgTailCall StgConArg" -- Only occur in argument positions
89 Literals are similar to constructors; they return by putting
90 themselves in an appropriate register and returning to the address on
94 cgTailCall (StgLitArg lit) [] live_vars
95 = performPrimReturn (CLit lit) live_vars
98 Treat unboxed locals exactly like literals (above) except use the addr
99 mode for the local instead of (CLit lit) in the assignment.
101 Case for unboxed @Ids@ first:
103 cgTailCall atom@(StgVarArg fun) [] live_vars
104 | isPrimType (idType fun)
105 = getCAddrMode fun `thenFC` \ amode ->
106 performPrimReturn amode live_vars
109 The general case (@fun@ is boxed):
111 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
114 %************************************************************************
116 \subsection[return-and-tail-call]{Return and tail call}
118 %************************************************************************
122 A quick bit of hacking to try to solve my void#-leaking blues...
124 I think I'm getting bitten by this stuff because code like
127 case ds.s12 :: IoWorld of {
128 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
129 IoWorld ds.s13# -> ds.s13#;
133 causes me to try to allocate a register to return the result in. The
134 hope is that the following will avoid such problems (and that Will
135 will do this in a cleaner way when he hits the same problem).
140 performPrimReturn :: CAddrMode -- The thing to return
144 performPrimReturn amode live_vars
146 kind = getAmodeRep amode
147 ret_reg = dataReturnConvPrim kind
149 assign_possibly = case kind of
151 kind -> (CAssign (CReg ret_reg) amode)
153 performReturn assign_possibly mkPrimReturnCode live_vars
155 mkPrimReturnCode :: Sequel -> Code
156 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
157 mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
158 absC (CReturn dest_amode DirectReturn)
159 -- Direct, no vectoring
161 -- All constructor arguments in registers; Node and InfoPtr are set.
162 -- All that remains is
163 -- (a) to set TagReg, if necessary
164 -- (b) to set InfoPtr to the info ptr, if necessary
165 -- (c) to do the right sort of jump.
167 mkStaticAlgReturnCode :: Id -- The constructor
168 -> Maybe CLabel -- The info ptr, if it isn't already set
169 -> Sequel -- where to return to
172 mkStaticAlgReturnCode con maybe_info_lbl sequel
173 = -- Generate profiling code if necessary
174 (case return_convention of
175 VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
179 -- Set tag if necessary
180 -- This is done by a macro, because if we are short of registers
181 -- we don't set TagReg; instead the continuation gets the tag
182 -- by indexing off the info ptr
183 (case return_convention of
185 UnvectoredReturn no_of_constrs
187 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
192 -- Generate the right jump or return
194 UpdateCode _ -> -- Ha! We know the constructor,
195 -- so we can go direct to the correct
196 -- update code for that constructor
198 -- Set the info pointer, and jump
200 absC (CJump (CLbl update_label CodePtrRep))
202 CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
203 -- we can go right to the alternative
205 -- No need to set info ptr when returning to a
206 -- known join point. After all, the code at
207 -- the destination knows what constructor it
208 -- is going to handle.
210 case assocMaybe alts tag of
211 Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
212 Nothing -> panic "mkStaticAlgReturnCode: default"
213 -- The Nothing case should never happen; it's the subject
214 -- of a wad of special-case code in cgReturnCon
216 other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
217 -- Set the info pointer, and jump
219 sequelToAmode sequel `thenFC` \ ret_amode ->
220 absC (CReturn ret_amode return_info)
225 tycon = dataConTyCon con
226 return_convention = ctrlReturnConvAlg tycon
227 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
228 -- cf AbsCUtils.mkAlgAltsCSwitch
231 = case (dataReturnConvAlg con) of
232 ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
233 ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
235 return_info = case return_convention of
236 UnvectoredReturn _ -> DirectReturn
237 VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
239 set_info_ptr = case maybe_info_lbl of
241 Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
244 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
246 mkDynamicAlgReturnCode tycon dyn_tag sequel
247 = case ctrlReturnConvAlg tycon of
250 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
251 sequelToAmode sequel `thenFC` \ ret_addr ->
252 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
254 UnvectoredReturn no_of_constrs ->
256 -- Set tag if necessary
257 -- This is done by a macro, because if we are short of registers
258 -- we don't set TagReg; instead the continuation gets the tag
259 -- by indexing off the info ptr
260 (if no_of_constrs > 1 then
261 absC (CMacroStmt SET_TAG [dyn_tag])
267 sequelToAmode sequel `thenFC` \ ret_addr ->
268 -- Generate the right jump or return
269 absC (CReturn ret_addr DirectReturn)
273 performReturn :: AbstractC -- Simultaneous assignments to perform
274 -> (Sequel -> Code) -- The code to execute to actually do
275 -- the return, given an addressing mode
276 -- for the return address
280 performReturn sim_assts finish_code live_vars
281 = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
283 -- Do the simultaneous assignments,
284 doSimAssts args_spa live_vars sim_assts `thenC`
286 -- Adjust stack pointers
287 adjustRealSps args_spa args_spb `thenC`
290 finish_code sequel -- "sequel" is `robust' in that it doesn't
291 -- depend on stk-ptr values
295 performTailCall :: Id -- Function
300 performTailCall fun args live_vars
301 = -- Get all the info we have about the function and args and go on to
303 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
304 getArgAmodes args `thenFC` \ arg_amodes ->
307 fun fun_amode lf_info arg_amodes
308 live_vars AbsCNop {- No pending assignments -}
311 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
312 -> LambdaFormInfo -- Info about the function
313 -> [CAddrMode] -- Arguments
314 -> StgLiveVars -- Live in continuation
316 -> AbstractC -- Pending simultaneous assignments
317 -- *** GUARANTEED to contain only stack assignments.
318 -- In ptic, we don't need to look in here to
319 -- discover all live regs
323 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
324 = nodeMustPointToIt lf_info `thenFC` \ node_points ->
325 getEntryConvention fun lf_info
326 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
328 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
332 = if node_points then
333 CAssign (CReg node) fun_amode
337 (arg_regs, finish_code)
342 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
343 CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
345 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
346 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
348 CJump (CLbl lbl CodePtrRep))
349 DirectEntry lbl arity regs ->
350 (regs, CJump (CLbl lbl CodePtrRep))
352 no_of_args = length arg_amodes
354 (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
355 -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
358 = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
360 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
363 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
365 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
366 -- If ASSERTion fails: Oops: the join point has *lower*
367 -- stack ptrs than the continuation Note that we take
368 -- the SpB point without the return address here. The
369 -- return address is put on by the let-no-escapey thing
372 mkStkAmodes join_spa join_spb stk_arg_amodes
373 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
375 -- Do the simultaneous assignments,
376 doSimAssts join_spa live_vars
377 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
381 adjustRealSps final_spa final_spb `thenC`
383 -- Jump to join point
386 _ -> -- else: not a let-no-escape (the common case)
388 -- Make instruction to save return address
389 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
391 mkStkAmodes args_spa args_spb stk_arg_amodes
393 \ (final_spa, final_spb, stk_arg_assts) ->
395 -- The B-stack space for the pushed return addess, with any args pushed
396 -- on top, is recorded in final_spb.
398 -- Do the simultaneous assignments,
399 doSimAssts args_spa live_vars
400 (mkAbstractCs [pending_assts, node_asst, ret_asst,
401 reg_arg_assts, stk_arg_assts])
404 -- Final adjustment of stack pointers
405 adjustRealSps final_spa final_spb `thenC`
407 -- Now decide about semi-tagging
409 semi_tagging_on = opt_DoSemiTagging
411 case (semi_tagging_on, arg_amodes, node_points, sequel) of
414 -- *************** The semi-tagging case ***************
416 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
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
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
429 -- But not always! The example I came across is when we have
430 -- a top-level Double:
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.)
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)
441 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
442 join_details_to_code join_details)
443 | (tag, join_details) <- st_alts
447 -- Enter Node (we know infoptr will have the info ptr in it)!
449 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
450 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
451 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
455 CAssign (CReg infoptr)
456 (CVal (NodeRel zeroOff) DataPtrRep),
458 case maybe_deflt_join_details of
460 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
464 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
465 [(mkMachInt 0, enter_jump)]
467 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
469 (join_details_to_code details))
473 -- *************** The non-semi-tagging case ***************
475 other -> absC finish_code
479 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
481 loadRetAddrIntoRetReg InRetReg
482 = returnFC AbsCNop -- Return address already there
484 loadRetAddrIntoRetReg sequel
485 = sequelToAmode sequel `thenFC` \ amode ->
486 returnFC (CAssign (CReg RetReg) amode)
490 %************************************************************************
492 \subsection[doSimAssts]{@doSimAssts@}
494 %************************************************************************
496 @doSimAssts@ happens at the end of every block of code.
497 They are separate because we sometimes do some jiggery-pokery in between.
500 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
501 -> StgLiveVars -- Live in continuation
505 doSimAssts tail_spa live_vars sim_assts
506 = -- Do the simultaneous assignments
507 absC (CSimultaneous sim_assts) `thenC`
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.
517 -- Emit code to stub dead regs; this only generates actual
518 -- machine instructions in in the DEBUG version
519 -- *** NOT DONE YET ***
523 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
524 mapCs stub_A_slot a_slots
527 stub_A_slot :: VirtualSpAOffset -> Code
528 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
529 absC (CAssign (CVal spa_rel PtrRep)