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_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
317 = nodeMustPointToIt lf_info `thenFC` \ node_points ->
318 getEntryConvention fun lf_info
319 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
321 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
325 = if node_points then
326 CAssign (CReg node) fun_amode
330 (arg_regs, finish_code)
335 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
336 CAssign (CReg infoptr)
338 (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
339 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
341 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
342 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
344 CJump (CLbl lbl CodePtrRep))
345 DirectEntry lbl arity regs ->
346 (regs, CJump (CLbl lbl CodePtrRep))
348 no_of_args = length arg_amodes
350 (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
351 -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
354 = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
356 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
359 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
361 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
362 -- If ASSERTion fails: Oops: the join point has *lower*
363 -- stack ptrs than the continuation Note that we take
364 -- the SpB point without the return address here. The
365 -- return address is put on by the let-no-escapey thing
368 mkStkAmodes join_spa join_spb stk_arg_amodes
369 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
371 -- Do the simultaneous assignments,
372 doSimAssts join_spa live_vars
373 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
377 adjustRealSps final_spa final_spb `thenC`
379 -- Jump to join point
382 _ -> -- else: not a let-no-escape (the common case)
384 -- Make instruction to save return address
385 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
387 mkStkAmodes args_spa args_spb stk_arg_amodes
389 \ (final_spa, final_spb, stk_arg_assts) ->
391 -- The B-stack space for the pushed return addess, with any args pushed
392 -- on top, is recorded in final_spb.
394 -- Do the simultaneous assignments,
395 doSimAssts args_spa live_vars
396 (mkAbstractCs [pending_assts, node_asst, ret_asst,
397 reg_arg_assts, stk_arg_assts])
400 -- Final adjustment of stack pointers
401 adjustRealSps final_spa final_spb `thenC`
403 -- Now decide about semi-tagging
405 semi_tagging_on = opt_DoSemiTagging
407 case (semi_tagging_on, arg_amodes, node_points, sequel) of
410 -- *************** The semi-tagging case ***************
412 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
414 -- Whoppee! Semi-tagging rules OK!
415 -- (a) semi-tagging is switched on
416 -- (b) there are no arguments,
417 -- (c) Node points to the closure
418 -- (d) we have a case-alternative sequel with
419 -- some visible alternatives
421 -- Why is test (c) necessary?
422 -- Usually Node will point to it at this point, because we're
423 -- scrutinsing something which is either a thunk or a
425 -- But not always! The example I came across is when we have
426 -- a top-level Double:
428 -- ... (case lit.3 of ...) ...
429 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
430 -- (OK, the simplifier should have eliminated this, but it's
431 -- easy to deal with the case anyway.)
433 join_details_to_code (load_regs_and_profiling_code, join_lbl)
434 = load_regs_and_profiling_code `mkAbsCStmts`
435 CJump (CLbl join_lbl CodePtrRep)
437 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
438 join_details_to_code join_details)
439 | (tag, join_details) <- st_alts
443 -- Enter Node (we know infoptr will have the info ptr in it)!
445 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
446 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
447 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
451 CAssign (CReg infoptr)
452 (CVal (NodeRel zeroOff) DataPtrRep),
454 case maybe_deflt_join_details of
456 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
460 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
461 [(mkMachInt 0, enter_jump)]
463 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
465 (join_details_to_code details))
469 -- *************** The non-semi-tagging case ***************
471 other -> absC finish_code
475 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
477 loadRetAddrIntoRetReg InRetReg
478 = returnFC AbsCNop -- Return address already there
480 loadRetAddrIntoRetReg sequel
481 = sequelToAmode sequel `thenFC` \ amode ->
482 returnFC (CAssign (CReg RetReg) amode)
486 %************************************************************************
488 \subsection[doSimAssts]{@doSimAssts@}
490 %************************************************************************
492 @doSimAssts@ happens at the end of every block of code.
493 They are separate because we sometimes do some jiggery-pokery in between.
496 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
497 -> StgLiveVars -- Live in continuation
501 doSimAssts tail_spa live_vars sim_assts
502 = -- Do the simultaneous assignments
503 absC (CSimultaneous sim_assts) `thenC`
505 -- Stub any unstubbed slots; the only live variables are indicated in
506 -- the end-of-block info in the monad
507 nukeDeadBindings live_vars `thenC`
508 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
509 -- Passing in tail_spa here should actually be redundant, because
510 -- the stack should be trimmed (by nukeDeadBindings) to
511 -- exactly the tail_spa position anyhow.
513 -- Emit code to stub dead regs; this only generates actual
514 -- machine instructions in in the DEBUG version
515 -- *** NOT DONE YET ***
519 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
520 mapCs stub_A_slot a_slots
523 stub_A_slot :: VirtualSpAOffset -> Code
524 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
525 absC (CAssign (CVal spa_rel PtrRep)