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(..),
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 Util ( zipWithEqual, panic, assertPanic )
53 %************************************************************************
55 \subsection[tailcall-doc]{Documentation}
57 %************************************************************************
60 cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
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.)
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.
73 Things to be careful about:
75 \item Don't overwrite stack locations before you have finished with
76 them (remember you need the function and the as-yet-unmoved
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.
83 Literals are similar to constructors; they return by putting
84 themselves in an appropriate register and returning to the address on
88 cgTailCall (StgLitArg lit) [] live_vars
89 = performPrimReturn (CLit lit) live_vars
92 Treat unboxed locals exactly like literals (above) except use the addr
93 mode for the local instead of (CLit lit) in the assignment.
95 Case for unboxed @Ids@ first:
97 cgTailCall atom@(StgVarArg fun) [] live_vars
98 | isPrimType (idType fun)
99 = getCAddrMode fun `thenFC` \ amode ->
100 performPrimReturn amode live_vars
103 The general case (@fun@ is boxed):
105 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
108 %************************************************************************
110 \subsection[return-and-tail-call]{Return and tail call}
112 %************************************************************************
116 A quick bit of hacking to try to solve my void#-leaking blues...
118 I think I'm getting bitten by this stuff because code like
121 case ds.s12 :: IoWorld of {
122 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
123 IoWorld ds.s13# -> ds.s13#;
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).
134 performPrimReturn :: CAddrMode -- The thing to return
138 performPrimReturn amode live_vars
140 kind = getAmodeRep amode
141 ret_reg = dataReturnConvPrim kind
143 assign_possibly = case kind of
145 kind -> (CAssign (CReg ret_reg) amode)
147 performReturn assign_possibly mkPrimReturnCode live_vars
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
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.
161 mkStaticAlgReturnCode :: Id -- The constructor
162 -> Maybe CLabel -- The info ptr, if it isn't already set
163 -> Sequel -- where to return to
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]
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
179 UnvectoredReturn no_of_constrs
181 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
186 -- Generate the right jump or return
188 UpdateCode _ -> -- Ha! We know the constructor,
189 -- so we can go direct to the correct
190 -- update code for that constructor
192 -- Set the info pointer, and jump
194 absC (CJump (CLbl update_label CodePtrRep))
196 CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
197 -- we can go right to the alternative
199 -- No need to set info ptr when returning to a
200 -- known join point. After all, the code at
201 -- the destination knows what constructor it
202 -- is going to handle.
204 case assocMaybe alts tag of
205 Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
206 Nothing -> panic "mkStaticAlgReturnCode: default"
207 -- The Nothing case should never happen; it's the subject
208 -- of a wad of special-case code in cgReturnCon
210 other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
211 -- Set the info pointer, and jump
213 sequelToAmode sequel `thenFC` \ ret_amode ->
214 absC (CReturn ret_amode return_info)
219 tycon = dataConTyCon con
220 return_convention = ctrlReturnConvAlg tycon
221 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
222 -- cf AbsCUtils.mkAlgAltsCSwitch
225 = case (dataReturnConvAlg con) of
226 ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
227 ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
229 return_info = case return_convention of
230 UnvectoredReturn _ -> DirectReturn
231 VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
233 set_info_ptr = case maybe_info_lbl of
235 Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
238 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
240 mkDynamicAlgReturnCode tycon dyn_tag sequel
241 = case ctrlReturnConvAlg tycon of
244 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
245 sequelToAmode sequel `thenFC` \ ret_addr ->
246 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
248 UnvectoredReturn no_of_constrs ->
250 -- Set tag if necessary
251 -- This is done by a macro, because if we are short of registers
252 -- we don't set TagReg; instead the continuation gets the tag
253 -- by indexing off the info ptr
254 (if no_of_constrs > 1 then
255 absC (CMacroStmt SET_TAG [dyn_tag])
261 sequelToAmode sequel `thenFC` \ ret_addr ->
262 -- Generate the right jump or return
263 absC (CReturn ret_addr DirectReturn)
267 performReturn :: AbstractC -- Simultaneous assignments to perform
268 -> (Sequel -> Code) -- The code to execute to actually do
269 -- the return, given an addressing mode
270 -- for the return address
274 performReturn sim_assts finish_code live_vars
275 = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
277 -- Do the simultaneous assignments,
278 doSimAssts args_spa live_vars sim_assts `thenC`
280 -- Adjust stack pointers
281 adjustRealSps args_spa args_spb `thenC`
284 finish_code sequel -- "sequel" is `robust' in that it doesn't
285 -- depend on stk-ptr values
289 performTailCall :: Id -- Function
294 performTailCall fun args live_vars
295 = -- Get all the info we have about the function and args and go on to
297 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
298 getArgAmodes args `thenFC` \ arg_amodes ->
301 fun fun_amode lf_info arg_amodes
302 live_vars AbsCNop {- No pending assignments -}
305 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
306 -> LambdaFormInfo -- Info about the function
307 -> [CAddrMode] -- Arguments
308 -> StgLiveVars -- Live in continuation
310 -> AbstractC -- Pending simultaneous assignments
311 -- *** GUARANTEED to contain only stack assignments.
312 -- In ptic, we don't need to look in here to
313 -- discover all live regs
317 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
318 = nodeMustPointToIt lf_info `thenFC` \ node_points ->
319 getEntryConvention fun lf_info
320 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
322 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
326 = if node_points then
327 CAssign (CReg node) fun_amode
331 (arg_regs, finish_code)
336 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
337 CAssign (CReg infoptr)
339 (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
340 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
342 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
343 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
345 CJump (CLbl lbl CodePtrRep))
346 DirectEntry lbl arity regs ->
347 (regs, CJump (CLbl lbl CodePtrRep))
349 no_of_args = length arg_amodes
351 (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
352 -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
355 = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
357 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
360 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
362 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
363 -- If ASSERTion fails: Oops: the join point has *lower*
364 -- stack ptrs than the continuation Note that we take
365 -- the SpB point without the return address here. The
366 -- return address is put on by the let-no-escapey thing
369 mkStkAmodes join_spa join_spb stk_arg_amodes
370 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
372 -- Do the simultaneous assignments,
373 doSimAssts join_spa live_vars
374 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
378 adjustRealSps final_spa final_spb `thenC`
380 -- Jump to join point
383 _ -> -- else: not a let-no-escape (the common case)
385 -- Make instruction to save return address
386 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
388 mkStkAmodes args_spa args_spb stk_arg_amodes
390 \ (final_spa, final_spb, stk_arg_assts) ->
392 -- The B-stack space for the pushed return addess, with any args pushed
393 -- on top, is recorded in final_spb.
395 -- Do the simultaneous assignments,
396 doSimAssts args_spa live_vars
397 (mkAbstractCs [pending_assts, node_asst, ret_asst,
398 reg_arg_assts, stk_arg_assts])
401 -- Final adjustment of stack pointers
402 adjustRealSps final_spa final_spb `thenC`
404 -- Now decide about semi-tagging
406 semi_tagging_on = opt_DoSemiTagging
408 case (semi_tagging_on, arg_amodes, node_points, sequel) of
411 -- *************** The semi-tagging case ***************
413 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
415 -- Whoppee! Semi-tagging rules OK!
416 -- (a) semi-tagging is switched on
417 -- (b) there are no arguments,
418 -- (c) Node points to the closure
419 -- (d) we have a case-alternative sequel with
420 -- some visible alternatives
422 -- Why is test (c) necessary?
423 -- Usually Node will point to it at this point, because we're
424 -- scrutinsing something which is either a thunk or a
426 -- But not always! The example I came across is when we have
427 -- a top-level Double:
429 -- ... (case lit.3 of ...) ...
430 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
431 -- (OK, the simplifier should have eliminated this, but it's
432 -- easy to deal with the case anyway.)
434 join_details_to_code (load_regs_and_profiling_code, join_lbl)
435 = load_regs_and_profiling_code `mkAbsCStmts`
436 CJump (CLbl join_lbl CodePtrRep)
438 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
439 join_details_to_code join_details)
440 | (tag, join_details) <- st_alts
444 -- Enter Node (we know infoptr will have the info ptr in it)!
446 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
447 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
448 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
452 CAssign (CReg infoptr)
453 (CVal (NodeRel zeroOff) DataPtrRep),
455 case maybe_deflt_join_details of
457 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
461 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
462 [(mkMachInt 0, enter_jump)]
464 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
466 (join_details_to_code details))
470 -- *************** The non-semi-tagging case ***************
472 other -> absC finish_code
476 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
478 loadRetAddrIntoRetReg InRetReg
479 = returnFC AbsCNop -- Return address already there
481 loadRetAddrIntoRetReg sequel
482 = sequelToAmode sequel `thenFC` \ amode ->
483 returnFC (CAssign (CReg RetReg) amode)
487 %************************************************************************
489 \subsection[doSimAssts]{@doSimAssts@}
491 %************************************************************************
493 @doSimAssts@ happens at the end of every block of code.
494 They are separate because we sometimes do some jiggery-pokery in between.
497 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
498 -> StgLiveVars -- Live in continuation
502 doSimAssts tail_spa live_vars sim_assts
503 = -- Do the simultaneous assignments
504 absC (CSimultaneous sim_assts) `thenC`
506 -- Stub any unstubbed slots; the only live variables are indicated in
507 -- the end-of-block info in the monad
508 nukeDeadBindings live_vars `thenC`
509 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
510 -- Passing in tail_spa here should actually be redundant, because
511 -- the stack should be trimmed (by nukeDeadBindings) to
512 -- exactly the tail_spa position anyhow.
514 -- Emit code to stub dead regs; this only generates actual
515 -- machine instructions in in the DEBUG version
516 -- *** NOT DONE YET ***
520 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
521 mapCs stub_A_slot a_slots
524 stub_A_slot :: VirtualSpAOffset -> Code
525 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
526 absC (CAssign (CVal spa_rel PtrRep)