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.
84 cgTailCall (StgConArg con) args live_vars
85 = panic "cgTailCall StgConArg" -- Only occur in argument positions
88 Literals are similar to constructors; they return by putting
89 themselves in an appropriate register and returning to the address on
93 cgTailCall (StgLitArg lit) [] live_vars
94 = performPrimReturn (CLit lit) live_vars
97 Treat unboxed locals exactly like literals (above) except use the addr
98 mode for the local instead of (CLit lit) in the assignment.
100 Case for unboxed @Ids@ first:
102 cgTailCall atom@(StgVarArg fun) [] live_vars
103 | isPrimType (idType fun)
104 = getCAddrMode fun `thenFC` \ amode ->
105 performPrimReturn amode live_vars
108 The general case (@fun@ is boxed):
110 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
113 %************************************************************************
115 \subsection[return-and-tail-call]{Return and tail call}
117 %************************************************************************
121 A quick bit of hacking to try to solve my void#-leaking blues...
123 I think I'm getting bitten by this stuff because code like
126 case ds.s12 :: IoWorld of {
127 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
128 IoWorld ds.s13# -> ds.s13#;
132 causes me to try to allocate a register to return the result in. The
133 hope is that the following will avoid such problems (and that Will
134 will do this in a cleaner way when he hits the same problem).
139 performPrimReturn :: CAddrMode -- The thing to return
143 performPrimReturn amode live_vars
145 kind = getAmodeRep amode
146 ret_reg = dataReturnConvPrim kind
148 assign_possibly = case kind of
150 kind -> (CAssign (CReg ret_reg) amode)
152 performReturn assign_possibly mkPrimReturnCode live_vars
154 mkPrimReturnCode :: Sequel -> Code
155 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
156 mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
157 absC (CReturn dest_amode DirectReturn)
158 -- Direct, no vectoring
160 -- All constructor arguments in registers; Node and InfoPtr are set.
161 -- All that remains is
162 -- (a) to set TagReg, if necessary
163 -- (b) to set InfoPtr to the info ptr, if necessary
164 -- (c) to do the right sort of jump.
166 mkStaticAlgReturnCode :: Id -- The constructor
167 -> Maybe CLabel -- The info ptr, if it isn't already set
168 -> Sequel -- where to return to
171 mkStaticAlgReturnCode con maybe_info_lbl sequel
172 = -- Generate profiling code if necessary
173 (case return_convention of
174 VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
178 -- Set tag if necessary
179 -- This is done by a macro, because if we are short of registers
180 -- we don't set TagReg; instead the continuation gets the tag
181 -- by indexing off the info ptr
182 (case return_convention of
184 UnvectoredReturn no_of_constrs
186 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
191 -- Generate the right jump or return
193 UpdateCode _ -> -- Ha! We know the constructor,
194 -- so we can go direct to the correct
195 -- update code for that constructor
197 -- Set the info pointer, and jump
199 absC (CJump (CLbl update_label CodePtrRep))
201 CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
202 -- we can go right to the alternative
204 -- No need to set info ptr when returning to a
205 -- known join point. After all, the code at
206 -- the destination knows what constructor it
207 -- is going to handle.
209 case assocMaybe alts tag of
210 Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
211 Nothing -> panic "mkStaticAlgReturnCode: default"
212 -- The Nothing case should never happen; it's the subject
213 -- of a wad of special-case code in cgReturnCon
215 other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
216 -- Set the info pointer, and jump
218 sequelToAmode sequel `thenFC` \ ret_amode ->
219 absC (CReturn ret_amode return_info)
224 tycon = dataConTyCon con
225 return_convention = ctrlReturnConvAlg tycon
226 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
227 -- cf AbsCUtils.mkAlgAltsCSwitch
230 = case (dataReturnConvAlg con) of
231 ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
232 ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
234 return_info = case return_convention of
235 UnvectoredReturn _ -> DirectReturn
236 VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
238 set_info_ptr = case maybe_info_lbl of
240 Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
243 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
245 mkDynamicAlgReturnCode tycon dyn_tag sequel
246 = case ctrlReturnConvAlg tycon of
249 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
250 sequelToAmode sequel `thenFC` \ ret_addr ->
251 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
253 UnvectoredReturn no_of_constrs ->
255 -- Set tag if necessary
256 -- This is done by a macro, because if we are short of registers
257 -- we don't set TagReg; instead the continuation gets the tag
258 -- by indexing off the info ptr
259 (if no_of_constrs > 1 then
260 absC (CMacroStmt SET_TAG [dyn_tag])
266 sequelToAmode sequel `thenFC` \ ret_addr ->
267 -- Generate the right jump or return
268 absC (CReturn ret_addr DirectReturn)
272 performReturn :: AbstractC -- Simultaneous assignments to perform
273 -> (Sequel -> Code) -- The code to execute to actually do
274 -- the return, given an addressing mode
275 -- for the return address
279 performReturn sim_assts finish_code live_vars
280 = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
282 -- Do the simultaneous assignments,
283 doSimAssts args_spa live_vars sim_assts `thenC`
285 -- Adjust stack pointers
286 adjustRealSps args_spa args_spb `thenC`
289 finish_code sequel -- "sequel" is `robust' in that it doesn't
290 -- depend on stk-ptr values
294 performTailCall :: Id -- Function
299 performTailCall fun args live_vars
300 = -- Get all the info we have about the function and args and go on to
302 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
303 getArgAmodes args `thenFC` \ arg_amodes ->
306 fun fun_amode lf_info arg_amodes
307 live_vars AbsCNop {- No pending assignments -}
310 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
311 -> LambdaFormInfo -- Info about the function
312 -> [CAddrMode] -- Arguments
313 -> StgLiveVars -- Live in continuation
315 -> AbstractC -- Pending simultaneous assignments
316 -- *** GUARANTEED to contain only stack assignments.
317 -- In ptic, we don't need to look in here to
318 -- discover all live regs
322 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
323 = nodeMustPointToIt lf_info `thenFC` \ node_points ->
324 getEntryConvention fun lf_info
325 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
327 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
331 = if node_points then
332 CAssign (CReg node) fun_amode
336 (arg_regs, finish_code)
341 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
342 CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
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, CJump (CLbl lbl CodePtrRep))
351 no_of_args = length arg_amodes
353 (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
354 -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
357 = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
359 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
362 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
364 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
365 -- If ASSERTion fails: Oops: the join point has *lower*
366 -- stack ptrs than the continuation Note that we take
367 -- the SpB point without the return address here. The
368 -- return address is put on by the let-no-escapey thing
371 mkStkAmodes join_spa join_spb stk_arg_amodes
372 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
374 -- Do the simultaneous assignments,
375 doSimAssts join_spa live_vars
376 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
380 adjustRealSps final_spa final_spb `thenC`
382 -- Jump to join point
385 _ -> -- else: not a let-no-escape (the common case)
387 -- Make instruction to save return address
388 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
390 mkStkAmodes args_spa args_spb stk_arg_amodes
392 \ (final_spa, final_spb, stk_arg_assts) ->
394 -- The B-stack space for the pushed return addess, with any args pushed
395 -- on top, is recorded in final_spb.
397 -- Do the simultaneous assignments,
398 doSimAssts args_spa live_vars
399 (mkAbstractCs [pending_assts, node_asst, ret_asst,
400 reg_arg_assts, stk_arg_assts])
403 -- Final adjustment of stack pointers
404 adjustRealSps final_spa final_spb `thenC`
406 -- Now decide about semi-tagging
408 semi_tagging_on = opt_DoSemiTagging
410 case (semi_tagging_on, arg_amodes, node_points, sequel) of
413 -- *************** The semi-tagging case ***************
415 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
417 -- Whoppee! Semi-tagging rules OK!
418 -- (a) semi-tagging is switched on
419 -- (b) there are no arguments,
420 -- (c) Node points to the closure
421 -- (d) we have a case-alternative sequel with
422 -- some visible alternatives
424 -- Why is test (c) necessary?
425 -- Usually Node will point to it at this point, because we're
426 -- scrutinsing something which is either a thunk or a
428 -- But not always! The example I came across is when we have
429 -- a top-level Double:
431 -- ... (case lit.3 of ...) ...
432 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
433 -- (OK, the simplifier should have eliminated this, but it's
434 -- easy to deal with the case anyway.)
436 join_details_to_code (load_regs_and_profiling_code, join_lbl)
437 = load_regs_and_profiling_code `mkAbsCStmts`
438 CJump (CLbl join_lbl CodePtrRep)
440 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
441 join_details_to_code join_details)
442 | (tag, join_details) <- st_alts
446 -- Enter Node (we know infoptr will have the info ptr in it)!
448 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
449 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
450 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
454 CAssign (CReg infoptr)
455 (CVal (NodeRel zeroOff) DataPtrRep),
457 case maybe_deflt_join_details of
459 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
463 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
464 [(mkMachInt 0, enter_jump)]
466 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
468 (join_details_to_code details))
472 -- *************** The non-semi-tagging case ***************
474 other -> absC finish_code
478 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
480 loadRetAddrIntoRetReg InRetReg
481 = returnFC AbsCNop -- Return address already there
483 loadRetAddrIntoRetReg sequel
484 = sequelToAmode sequel `thenFC` \ amode ->
485 returnFC (CAssign (CReg RetReg) amode)
489 %************************************************************************
491 \subsection[doSimAssts]{@doSimAssts@}
493 %************************************************************************
495 @doSimAssts@ happens at the end of every block of code.
496 They are separate because we sometimes do some jiggery-pokery in between.
499 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
500 -> StgLiveVars -- Live in continuation
504 doSimAssts tail_spa live_vars sim_assts
505 = -- Do the simultaneous assignments
506 absC (CSimultaneous sim_assts) `thenC`
508 -- Stub any unstubbed slots; the only live variables are indicated in
509 -- the end-of-block info in the monad
510 nukeDeadBindings live_vars `thenC`
511 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
512 -- Passing in tail_spa here should actually be redundant, because
513 -- the stack should be trimmed (by nukeDeadBindings) to
514 -- exactly the tail_spa position anyhow.
516 -- Emit code to stub dead regs; this only generates actual
517 -- machine instructions in in the DEBUG version
518 -- *** NOT DONE YET ***
522 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
523 mapCs stub_A_slot a_slots
526 stub_A_slot :: VirtualSpAOffset -> Code
527 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
528 absC (CAssign (CVal spa_rel PtrRep)