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 )
36 import ClosureInfo ( nodeMustPointToIt,
37 getEntryConvention, EntryConvention(..)
39 import CmdLineOpts ( opt_EmitArityChecks, opt_DoSemiTagging )
40 import HeapOffs ( zeroOff, VirtualSpAOffset(..) )
41 import Id ( idType, dataConTyCon, dataConTag,
44 import Literal ( mkMachInt )
45 import Maybes ( assocMaybe )
46 import PrimRep ( PrimRep(..) )
47 import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) )
48 import Type ( isPrimType )
49 import Util ( zipWithEqual, panic, assertPanic )
52 %************************************************************************
54 \subsection[tailcall-doc]{Documentation}
56 %************************************************************************
59 cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
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.)
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.
72 Things to be careful about:
74 \item Don't overwrite stack locations before you have finished with
75 them (remember you need the function and the as-yet-unmoved
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.
82 Literals are similar to constructors; they return by putting
83 themselves in an appropriate register and returning to the address on
87 cgTailCall (StgLitArg lit) [] live_vars
88 = performPrimReturn (CLit lit) live_vars
91 Treat unboxed locals exactly like literals (above) except use the addr
92 mode for the local instead of (CLit lit) in the assignment.
94 Case for unboxed @Ids@ first:
96 cgTailCall atom@(StgVarArg fun) [] live_vars
97 | isPrimType (idType fun)
98 = getCAddrMode fun `thenFC` \ amode ->
99 performPrimReturn amode live_vars
102 The general case (@fun@ is boxed):
104 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
107 %************************************************************************
109 \subsection[return-and-tail-call]{Return and tail call}
111 %************************************************************************
115 A quick bit of hacking to try to solve my void#-leaking blues...
117 I think I'm getting bitten by this stuff because code like
120 case ds.s12 :: IoWorld of {
121 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
122 IoWorld ds.s13# -> ds.s13#;
126 causes me to try to allocate a register to return the result in. The
127 hope is that the following will avoid such problems (and that Will
128 will do this in a cleaner way when he hits the same problem).
133 performPrimReturn :: CAddrMode -- The thing to return
137 performPrimReturn amode live_vars
139 kind = getAmodeRep amode
140 ret_reg = dataReturnConvPrim kind
142 assign_possibly = case kind of
144 kind -> (CAssign (CReg ret_reg) amode)
146 performReturn assign_possibly mkPrimReturnCode live_vars
148 mkPrimReturnCode :: Sequel -> Code
149 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
150 mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
151 absC (CReturn dest_amode DirectReturn)
152 -- Direct, no vectoring
154 -- All constructor arguments in registers; Node and InfoPtr are set.
155 -- All that remains is
156 -- (a) to set TagReg, if necessary
157 -- (b) to set InfoPtr to the info ptr, if necessary
158 -- (c) to do the right sort of jump.
160 mkStaticAlgReturnCode :: Id -- The constructor
161 -> Maybe CLabel -- The info ptr, if it isn't already set
162 -> Sequel -- where to return to
165 mkStaticAlgReturnCode con maybe_info_lbl sequel
166 = -- Generate profiling code if necessary
167 (case return_convention of
168 VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
172 -- Set tag if necessary
173 -- This is done by a macro, because if we are short of registers
174 -- we don't set TagReg; instead the continuation gets the tag
175 -- by indexing off the info ptr
176 (case return_convention of
178 UnvectoredReturn no_of_constrs
180 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
185 -- Generate the right jump or return
187 UpdateCode _ -> -- Ha! We know the constructor,
188 -- so we can go direct to the correct
189 -- update code for that constructor
191 -- Set the info pointer, and jump
193 absC (CJump (CLbl update_label CodePtrRep))
195 CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
196 -- we can go right to the alternative
198 -- No need to set info ptr when returning to a
199 -- known join point. After all, the code at
200 -- the destination knows what constructor it
201 -- is going to handle.
203 case assocMaybe alts tag of
204 Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
205 Nothing -> panic "mkStaticAlgReturnCode: default"
206 -- The Nothing case should never happen; it's the subject
207 -- of a wad of special-case code in cgReturnCon
209 other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
210 -- Set the info pointer, and jump
212 sequelToAmode sequel `thenFC` \ ret_amode ->
213 absC (CReturn ret_amode return_info)
218 tycon = dataConTyCon con
219 return_convention = ctrlReturnConvAlg tycon
220 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
221 -- cf AbsCUtils.mkAlgAltsCSwitch
224 = case (dataReturnConvAlg con) of
225 ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
226 ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
228 return_info = case return_convention of
229 UnvectoredReturn _ -> DirectReturn
230 VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
232 set_info_ptr = case maybe_info_lbl of
234 Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
237 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
239 mkDynamicAlgReturnCode tycon dyn_tag sequel
240 = case ctrlReturnConvAlg tycon of
243 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
244 sequelToAmode sequel `thenFC` \ ret_addr ->
245 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
247 UnvectoredReturn no_of_constrs ->
249 -- Set tag if necessary
250 -- This is done by a macro, because if we are short of registers
251 -- we don't set TagReg; instead the continuation gets the tag
252 -- by indexing off the info ptr
253 (if no_of_constrs > 1 then
254 absC (CMacroStmt SET_TAG [dyn_tag])
260 sequelToAmode sequel `thenFC` \ ret_addr ->
261 -- Generate the right jump or return
262 absC (CReturn ret_addr DirectReturn)
266 performReturn :: AbstractC -- Simultaneous assignments to perform
267 -> (Sequel -> Code) -- The code to execute to actually do
268 -- the return, given an addressing mode
269 -- for the return address
273 performReturn sim_assts finish_code live_vars
274 = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
276 -- Do the simultaneous assignments,
277 doSimAssts args_spa live_vars sim_assts `thenC`
279 -- Adjust stack pointers
280 adjustRealSps args_spa args_spb `thenC`
283 finish_code sequel -- "sequel" is `robust' in that it doesn't
284 -- depend on stk-ptr values
288 performTailCall :: Id -- Function
293 performTailCall fun args live_vars
294 = -- Get all the info we have about the function and args and go on to
296 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
297 getArgAmodes args `thenFC` \ arg_amodes ->
300 fun fun_amode lf_info arg_amodes
301 live_vars AbsCNop {- No pending assignments -}
304 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
305 -> LambdaFormInfo -- Info about the function
306 -> [CAddrMode] -- Arguments
307 -> StgLiveVars -- Live in continuation
309 -> AbstractC -- Pending simultaneous assignments
310 -- *** GUARANTEED to contain only stack assignments.
311 -- In ptic, we don't need to look in here to
312 -- discover all live regs
316 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
318 do_arity_chks = opt_EmitArityChecks
320 nodeMustPointToIt lf_info `thenFC` \ node_points ->
321 getEntryConvention fun lf_info
322 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
324 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
328 = if node_points then
329 CAssign (CReg node) fun_amode
333 (arg_regs, finish_code)
338 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
339 CAssign (CReg infoptr)
341 (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
342 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
344 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
345 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
347 CJump (CLbl lbl CodePtrRep))
348 DirectEntry lbl arity regs ->
349 (regs, (if do_arity_chks
350 then CMacroStmt SET_ARITY [mkIntCLit arity]
352 `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
354 no_of_args = length arg_amodes
356 (reg_arg_assts, stk_arg_amodes)
357 = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
358 drop (length arg_regs) arg_amodes) -- No regs, or
361 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
364 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
366 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
367 -- If ASSERTion fails: Oops: the join point has *lower*
368 -- stack ptrs than the continuation Note that we take
369 -- the SpB point without the return address here. The
370 -- return address is put on by the let-no-escapey thing
373 mkStkAmodes join_spa join_spb stk_arg_amodes
374 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
376 -- Do the simultaneous assignments,
377 doSimAssts join_spa live_vars
378 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
382 adjustRealSps final_spa final_spb `thenC`
384 -- Jump to join point
387 _ -> -- else: not a let-no-escape (the common case)
389 -- Make instruction to save return address
390 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
392 mkStkAmodes args_spa args_spb stk_arg_amodes
394 \ (final_spa, final_spb, stk_arg_assts) ->
396 -- The B-stack space for the pushed return addess, with any args pushed
397 -- on top, is recorded in final_spb.
399 -- Do the simultaneous assignments,
400 doSimAssts args_spa live_vars
401 (mkAbstractCs [pending_assts, node_asst, ret_asst,
402 reg_arg_assts, stk_arg_assts])
405 -- Final adjustment of stack pointers
406 adjustRealSps final_spa final_spb `thenC`
408 -- Now decide about semi-tagging
410 semi_tagging_on = opt_DoSemiTagging
412 case (semi_tagging_on, arg_amodes, node_points, sequel) of
415 -- *************** The semi-tagging case ***************
417 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
419 -- Whoppee! Semi-tagging rules OK!
420 -- (a) semi-tagging is switched on
421 -- (b) there are no arguments,
422 -- (c) Node points to the closure
423 -- (d) we have a case-alternative sequel with
424 -- some visible alternatives
426 -- Why is test (c) necessary?
427 -- Usually Node will point to it at this point, because we're
428 -- scrutinsing something which is either a thunk or a
430 -- But not always! The example I came across is when we have
431 -- a top-level Double:
433 -- ... (case lit.3 of ...) ...
434 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
435 -- (OK, the simplifier should have eliminated this, but it's
436 -- easy to deal with the case anyway.)
438 join_details_to_code (load_regs_and_profiling_code, join_lbl)
439 = load_regs_and_profiling_code `mkAbsCStmts`
440 CJump (CLbl join_lbl CodePtrRep)
442 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
443 join_details_to_code join_details)
444 | (tag, join_details) <- st_alts
448 -- Enter Node (we know infoptr will have the info ptr in it)!
450 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
451 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
452 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
456 CAssign (CReg infoptr)
457 (CVal (NodeRel zeroOff) DataPtrRep),
459 case maybe_deflt_join_details of
461 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
465 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
466 [(mkMachInt 0, enter_jump)]
468 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
470 (join_details_to_code details))
474 -- *************** The non-semi-tagging case ***************
476 other -> absC finish_code
480 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
482 loadRetAddrIntoRetReg InRetReg
483 = returnFC AbsCNop -- Return address already there
485 loadRetAddrIntoRetReg sequel
486 = sequelToAmode sequel `thenFC` \ amode ->
487 returnFC (CAssign (CReg RetReg) amode)
491 %************************************************************************
493 \subsection[doSimAssts]{@doSimAssts@}
495 %************************************************************************
497 @doSimAssts@ happens at the end of every block of code.
498 They are separate because we sometimes do some jiggery-pokery in between.
501 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
502 -> StgLiveVars -- Live in continuation
506 doSimAssts tail_spa live_vars sim_assts
507 = -- Do the simultaneous assignments
508 absC (CSimultaneous sim_assts) `thenC`
510 -- Stub any unstubbed slots; the only live variables are indicated in
511 -- the end-of-block info in the monad
512 nukeDeadBindings live_vars `thenC`
513 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
514 -- Passing in tail_spa here should actually be redundant, because
515 -- the stack should be trimmed (by nukeDeadBindings) to
516 -- exactly the tail_spa position anyhow.
518 -- Emit code to stub dead regs; this only generates actual
519 -- machine instructions in in the DEBUG version
520 -- *** NOT DONE YET ***
524 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
525 mapCs stub_A_slot a_slots
528 stub_A_slot :: VirtualSpAOffset -> Code
529 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
530 absC (CAssign (CVal spa_rel PtrRep)