2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %********************************************************
6 \section[CgTailCall]{Tail calls: converting @StgApps@}
8 %********************************************************
14 mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
20 #include "HsVersions.h"
25 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
26 import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
27 import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
28 ctrlReturnConvAlg, CtrlReturnConvention(..),
29 DataReturnConvention(..)
31 import CgStackery ( adjustRealSps, mkStkAmodes )
32 import CgUsages ( getSpARelOffset )
33 import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
34 import ClosureInfo ( nodeMustPointToIt,
35 getEntryConvention, EntryConvention(..),
38 import CmdLineOpts ( opt_DoSemiTagging )
39 import HeapOffs ( zeroOff, VirtualSpAOffset )
40 import Id ( idType, dataConTyCon, dataConTag,
43 import Literal ( mkMachInt )
44 import Maybes ( assocMaybe )
45 import PrimRep ( PrimRep(..) )
46 import StgSyn ( StgArg, GenStgArg(..), StgLiveVars )
47 import Type ( isUnpointedType )
48 import TyCon ( TyCon )
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.
83 cgTailCall (StgConArg con) args live_vars
84 = panic "cgTailCall StgConArg" -- Only occur in argument positions
87 Literals are similar to constructors; they return by putting
88 themselves in an appropriate register and returning to the address on
92 cgTailCall (StgLitArg lit) [] live_vars
93 = performPrimReturn (CLit lit) live_vars
96 Treat unboxed locals exactly like literals (above) except use the addr
97 mode for the local instead of (CLit lit) in the assignment.
99 Case for unboxed @Ids@ first:
101 cgTailCall atom@(StgVarArg fun) [] live_vars
102 | isUnpointedType (idType fun)
103 = getCAddrMode fun `thenFC` \ amode ->
104 performPrimReturn amode live_vars
107 The general case (@fun@ is boxed):
109 cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
112 %************************************************************************
114 \subsection[return-and-tail-call]{Return and tail call}
116 %************************************************************************
120 A quick bit of hacking to try to solve my void#-leaking blues...
122 I think I'm getting bitten by this stuff because code like
125 case ds.s12 :: IoWorld of {
126 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
127 IoWorld ds.s13# -> ds.s13#;
131 causes me to try to allocate a register to return the result in. The
132 hope is that the following will avoid such problems (and that Will
133 will do this in a cleaner way when he hits the same problem).
138 performPrimReturn :: CAddrMode -- The thing to return
142 performPrimReturn amode live_vars
144 kind = getAmodeRep amode
145 ret_reg = dataReturnConvPrim kind
147 assign_possibly = case kind of
149 kind -> (CAssign (CReg ret_reg) amode)
151 performReturn assign_possibly mkPrimReturnCode live_vars
153 mkPrimReturnCode :: Sequel -> Code
154 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
155 mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
156 absC (CReturn dest_amode DirectReturn)
157 -- Direct, no vectoring
159 -- All constructor arguments in registers; Node and InfoPtr are set.
160 -- All that remains is
161 -- (a) to set TagReg, if necessary
162 -- (b) to set InfoPtr to the info ptr, if necessary
163 -- (c) to do the right sort of jump.
165 mkStaticAlgReturnCode :: Id -- The constructor
166 -> Maybe CLabel -- The info ptr, if it isn't already set
167 -> Sequel -- where to return to
170 mkStaticAlgReturnCode con maybe_info_lbl sequel
171 = -- Generate profiling code if necessary
172 (case return_convention of
173 VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
177 -- Set tag if necessary
178 -- This is done by a macro, because if we are short of registers
179 -- we don't set TagReg; instead the continuation gets the tag
180 -- by indexing off the info ptr
181 (case return_convention of
183 UnvectoredReturn no_of_constrs
185 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
190 -- Generate the right jump or return
192 UpdateCode _ -> -- Ha! We know the constructor,
193 -- so we can go direct to the correct
194 -- update code for that constructor
196 -- Set the info pointer, and jump
198 absC (CJump (CLbl update_label CodePtrRep))
200 CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
201 -- we can go right to the alternative
203 -- No need to set info ptr when returning to a
204 -- known join point. After all, the code at
205 -- the destination knows what constructor it
206 -- is going to handle.
208 case assocMaybe alts tag of
209 Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
210 Nothing -> panic "mkStaticAlgReturnCode: default"
211 -- The Nothing case should never happen; it's the subject
212 -- of a wad of special-case code in cgReturnCon
214 other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
215 -- Set the info pointer, and jump
217 sequelToAmode sequel `thenFC` \ ret_amode ->
218 absC (CReturn ret_amode return_info)
223 tycon = dataConTyCon con
224 return_convention = ctrlReturnConvAlg tycon
225 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
226 -- cf AbsCUtils.mkAlgAltsCSwitch
229 = case (dataReturnConvAlg con) of
230 ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
231 ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
233 return_info = case return_convention of
234 UnvectoredReturn _ -> DirectReturn
235 VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
237 set_info_ptr = case maybe_info_lbl of
239 Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
242 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
244 mkDynamicAlgReturnCode tycon dyn_tag sequel
245 = case ctrlReturnConvAlg tycon of
248 profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
249 sequelToAmode sequel `thenFC` \ ret_addr ->
250 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
252 UnvectoredReturn no_of_constrs ->
254 -- Set tag if necessary
255 -- This is done by a macro, because if we are short of registers
256 -- we don't set TagReg; instead the continuation gets the tag
257 -- by indexing off the info ptr
258 (if no_of_constrs > 1 then
259 absC (CMacroStmt SET_TAG [dyn_tag])
265 sequelToAmode sequel `thenFC` \ ret_addr ->
266 -- Generate the right jump or return
267 absC (CReturn ret_addr DirectReturn)
271 performReturn :: AbstractC -- Simultaneous assignments to perform
272 -> (Sequel -> Code) -- The code to execute to actually do
273 -- the return, given an addressing mode
274 -- for the return address
278 performReturn sim_assts finish_code live_vars
279 = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
281 -- Do the simultaneous assignments,
282 doSimAssts args_spa live_vars sim_assts `thenC`
284 -- Adjust stack pointers
285 adjustRealSps args_spa args_spb `thenC`
288 finish_code sequel -- "sequel" is `robust' in that it doesn't
289 -- depend on stk-ptr values
293 performTailCall :: Id -- Function
298 performTailCall fun args live_vars
299 = -- Get all the info we have about the function and args and go on to
301 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
302 getArgAmodes args `thenFC` \ arg_amodes ->
305 fun fun_amode lf_info arg_amodes
306 live_vars AbsCNop {- No pending assignments -}
309 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
310 -> LambdaFormInfo -- Info about the function
311 -> [CAddrMode] -- Arguments
312 -> StgLiveVars -- Live in continuation
314 -> AbstractC -- Pending simultaneous assignments
315 -- *** GUARANTEED to contain only stack assignments.
316 -- In ptic, we don't need to look in here to
317 -- discover all live regs
321 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
322 = nodeMustPointToIt lf_info `thenFC` \ node_points ->
323 getEntryConvention fun lf_info
324 (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
326 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
330 = if node_points then
331 CAssign (CReg node) fun_amode
335 (arg_regs, finish_code)
340 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
341 CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
343 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
344 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
346 CJump (CLbl lbl CodePtrRep))
347 DirectEntry lbl arity regs ->
348 (regs, CJump (CLbl lbl CodePtrRep))
350 no_of_args = length arg_amodes
352 (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
353 -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
356 = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
358 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
361 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
363 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
364 -- If ASSERTion fails: Oops: the join point has *lower*
365 -- stack ptrs than the continuation Note that we take
366 -- the SpB point without the return address here. The
367 -- return address is put on by the let-no-escapey thing
370 mkStkAmodes join_spa join_spb stk_arg_amodes
371 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
373 -- Do the simultaneous assignments,
374 doSimAssts join_spa live_vars
375 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
379 adjustRealSps final_spa final_spb `thenC`
381 -- Jump to join point
384 _ -> -- else: not a let-no-escape (the common case)
386 -- Make instruction to save return address
387 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
389 mkStkAmodes args_spa args_spb stk_arg_amodes
391 \ (final_spa, final_spb, stk_arg_assts) ->
393 -- The B-stack space for the pushed return addess, with any args pushed
394 -- on top, is recorded in final_spb.
396 -- Do the simultaneous assignments,
397 doSimAssts args_spa live_vars
398 (mkAbstractCs [pending_assts, node_asst, ret_asst,
399 reg_arg_assts, stk_arg_assts])
402 -- Final adjustment of stack pointers
403 adjustRealSps final_spa final_spb `thenC`
405 -- Now decide about semi-tagging
407 semi_tagging_on = opt_DoSemiTagging
409 case (semi_tagging_on, arg_amodes, node_points, sequel) of
412 -- *************** The semi-tagging case ***************
414 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
416 -- Whoppee! Semi-tagging rules OK!
417 -- (a) semi-tagging is switched on
418 -- (b) there are no arguments,
419 -- (c) Node points to the closure
420 -- (d) we have a case-alternative sequel with
421 -- some visible alternatives
423 -- Why is test (c) necessary?
424 -- Usually Node will point to it at this point, because we're
425 -- scrutinsing something which is either a thunk or a
427 -- But not always! The example I came across is when we have
428 -- a top-level Double:
430 -- ... (case lit.3 of ...) ...
431 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
432 -- (OK, the simplifier should have eliminated this, but it's
433 -- easy to deal with the case anyway.)
435 join_details_to_code (load_regs_and_profiling_code, join_lbl)
436 = load_regs_and_profiling_code `mkAbsCStmts`
437 CJump (CLbl join_lbl CodePtrRep)
439 semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
440 join_details_to_code join_details)
441 | (tag, join_details) <- st_alts
445 -- Enter Node (we know infoptr will have the info ptr in it)!
447 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
448 [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
449 CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
453 CAssign (CReg infoptr)
454 (CVal (NodeRel zeroOff) DataPtrRep),
456 case maybe_deflt_join_details of
458 CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
462 CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
463 [(mkMachInt 0, enter_jump)]
465 (CMacroExpr IntRep INFO_TAG [CReg infoptr])
467 (join_details_to_code details))
471 -- *************** The non-semi-tagging case ***************
473 other -> absC finish_code
477 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
479 loadRetAddrIntoRetReg InRetReg
480 = returnFC AbsCNop -- Return address already there
482 loadRetAddrIntoRetReg sequel
483 = sequelToAmode sequel `thenFC` \ amode ->
484 returnFC (CAssign (CReg RetReg) amode)
488 %************************************************************************
490 \subsection[doSimAssts]{@doSimAssts@}
492 %************************************************************************
494 @doSimAssts@ happens at the end of every block of code.
495 They are separate because we sometimes do some jiggery-pokery in between.
498 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
499 -> StgLiveVars -- Live in continuation
503 doSimAssts tail_spa live_vars sim_assts
504 = -- Do the simultaneous assignments
505 absC (CSimultaneous sim_assts) `thenC`
507 -- Stub any unstubbed slots; the only live variables are indicated in
508 -- the end-of-block info in the monad
509 nukeDeadBindings live_vars `thenC`
510 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
511 -- Passing in tail_spa here should actually be redundant, because
512 -- the stack should be trimmed (by nukeDeadBindings) to
513 -- exactly the tail_spa position anyhow.
515 -- Emit code to stub dead regs; this only generates actual
516 -- machine instructions in in the DEBUG version
517 -- *** NOT DONE YET ***
521 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
522 mapCs stub_A_slot a_slots
525 stub_A_slot :: VirtualSpAOffset -> Code
526 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
527 absC (CAssign (CVal spa_rel PtrRep)