2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %********************************************************
6 \section[CgTailCall]{Tail calls: converting @StgApps@}
8 %********************************************************
11 #include "HsVersions.h"
16 mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
21 -- and to make the interface self-sufficient...
22 StgAtom, Id, CgState, CAddrMode, TyCon,
23 CgInfoDownwards, HeapOffset, Maybe
27 import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
34 import AbsUniType ( isPrimType, UniType )
35 import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
36 import CgCompInfo ( oTHER_TAG, iND_TAG )
37 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
39 CtrlReturnConvention(..), DataReturnConvention(..)
41 import CgStackery ( adjustRealSps, mkStkAmodes )
42 import CgUsages ( getSpARelOffset, getSpBRelOffset )
43 import CLabelInfo ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
44 import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
45 import CmdLineOpts ( GlobalSwitch(..) )
46 import Id ( getDataConTyCon, getDataConTag,
47 getIdUniType, getIdKind, fIRST_TAG, Id,
50 import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
51 import PrimKind ( retKindSize )
55 %************************************************************************
57 \subsection[tailcall-doc]{Documentation}
59 %************************************************************************
62 cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
65 Here's the code we generate for a tail call. (NB there may be no
66 arguments, in which case this boils down to just entering a variable.)
69 \item Adjust the stack ptr to \tr{tailSp + #args}.
70 \item Put args in the top locations of the resulting stack.
71 \item Make Node point to the function closure.
72 \item Enter the function closure.
75 Things to be careful about:
77 \item Don't overwrite stack locations before you have finished with
78 them (remember you need the function and the as-yet-unmoved
80 \item Preferably, generate no code to replace x by x on the stack (a
81 common situation in tail-recursion).
82 \item Adjust the stack high water mark appropriately.
85 Literals are similar to constructors; they return by putting
86 themselves in an appropriate register and returning to the address on
90 cgTailCall (StgLitAtom lit) [] live_vars
91 = performPrimReturn (CLit lit) live_vars
94 Treat unboxed locals exactly like literals (above) except use the addr
95 mode for the local instead of (CLit lit) in the assignment.
97 Case for unboxed @Ids@ first:
99 cgTailCall atom@(StgVarAtom fun) [] live_vars
100 | isPrimType (getIdUniType fun)
101 = getCAddrMode fun `thenFC` \ amode ->
102 performPrimReturn amode live_vars
105 The general case (@fun@ is boxed):
107 cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
110 %************************************************************************
112 \subsection[return-and-tail-call]{Return and tail call}
114 %************************************************************************
118 A quick bit of hacking to try to solve my void#-leaking blues...
120 I think I'm getting bitten by this stuff because code like
123 case ds.s12 :: IoWorld of {
124 -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
125 IoWorld ds.s13# -> ds.s13#;
129 causes me to try to allocate a register to return the result in. The
130 hope is that the following will avoid such problems (and that Will
131 will do this in a cleaner way when he hits the same problem).
136 performPrimReturn :: CAddrMode -- The thing to return
140 performPrimReturn amode live_vars
142 kind = getAmodeKind amode
143 ret_reg = dataReturnConvPrim kind
145 assign_possibly = case kind of
147 kind -> (CAssign (CReg ret_reg) amode)
149 performReturn assign_possibly mkPrimReturnCode live_vars
151 mkPrimReturnCode :: Sequel -> Code
152 --UNUSED:mkPrimReturnCode RestoreCostCentre = panic "mkPrimReturnCode: RCC"
153 mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
154 mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
155 absC (CReturn dest_amode DirectReturn)
156 -- Direct, no vectoring
158 -- All constructor arguments in registers; Node and InfoPtr are set.
159 -- All that remains is
160 -- (a) to set TagReg, if necessary
161 -- (b) to set InfoPtr to the info ptr, if necessary
162 -- (c) to do the right sort of jump.
164 mkStaticAlgReturnCode :: Id -- The constructor
165 -> Maybe CLabel -- The info ptr, if it isn't already set
166 -> Sequel -- where to return to
169 mkStaticAlgReturnCode con maybe_info_lbl sequel
170 = -- Generate profiling code if necessary
171 (case return_convention of
172 VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
176 -- Set tag if necessary
177 -- This is done by a macro, because if we are short of registers
178 -- we don't set TagReg; instead the continuation gets the tag
179 -- by indexing off the info ptr
180 (case return_convention of
182 UnvectoredReturn no_of_constrs
184 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
189 -- Generate the right jump or return
191 UpdateCode _ -> -- Ha! We know the constructor,
192 -- so we can go direct to the correct
193 -- update code for that constructor
195 -- Set the info pointer, and jump
197 getIntSwitchChkrC `thenFC` \ isw_chkr ->
198 absC (CJump (CLbl (update_label isw_chkr) CodePtrKind))
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 CodePtrKind))
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)
222 tag = getDataConTag con
223 tycon = getDataConTyCon con
224 return_convention = ctrlReturnConvAlg tycon
225 zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
226 -- cf AbsCFuns.mkAlgAltsCSwitch
228 update_label isw_chkr
229 = case (dataReturnConvAlg isw_chkr 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 DataPtrKind))
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 {-UNUSED:live_regs-} 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
291 --UNUSED: live_regs = getDestinationRegs sim_assts
292 -- ToDo: this is a *really* boring way to compute the
297 performTailCall :: Id -- Function
298 -> [PlainStgAtom] -- Args
302 performTailCall fun args live_vars
303 = -- Get all the info we have about the function and args and go on to
305 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
306 getAtomAmodes args `thenFC` \ arg_amodes ->
309 fun fun_amode lf_info arg_amodes
310 live_vars AbsCNop {- No pending assignments -}
313 tailCallBusiness :: Id -> CAddrMode -- Function and its amode
314 -> LambdaFormInfo -- Info about the function
315 -> [CAddrMode] -- Arguments
316 -> PlainStgLiveVars -- Live in continuation
318 -> AbstractC -- Pending simultaneous assignments
319 -- *** GUARANTEED to contain only stack assignments.
320 -- In ptic, we don't need to look in here to
321 -- discover all live regs
325 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
326 = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
328 nodeMustPointToIt lf_info `thenFC` \ node_points ->
329 getEntryConvention fun lf_info
330 (map getAmodeKind arg_amodes) `thenFC` \ entry_conv ->
332 getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
336 = if node_points then
337 CAssign (CReg node) fun_amode
341 (arg_regs, finish_code)
346 CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
347 CAssign (CReg infoptr)
349 (CMacroExpr DataPtrKind INFO_PTR [CReg node]),
350 CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
352 StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind))
353 StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
355 CJump (CLbl lbl CodePtrKind))
356 DirectEntry lbl arity regs ->
357 (regs, (if do_arity_chks
358 then CMacroStmt SET_ARITY [mkIntCLit arity]
360 `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
362 no_of_args = length arg_amodes
364 {- UNUSED: live_regs = if node_points then
369 (reg_arg_assts, stk_arg_amodes)
370 = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes),
371 drop (length arg_regs) arg_amodes) -- No regs, or
374 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
378 CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
380 ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
381 -- If ASSERTion fails: Oops: the join point has *lower*
382 -- stack ptrs than the continuation Note that we take
383 -- the SpB point without the return address here. The
384 -- return address is put on by the let-no-escapey thing
387 mkStkAmodes join_spa join_spb stk_arg_amodes
388 `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
390 -- Do the simultaneous assignments,
391 doSimAssts join_spa live_vars {-UNUSED: live_regs-}
392 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
396 adjustRealSps final_spa final_spb `thenC`
398 -- Jump to join point
401 _ -> -- else: not a let-no-escape (the common case)
403 -- Make instruction to save return address
404 loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
406 mkStkAmodes args_spa args_spb stk_arg_amodes
408 \ (final_spa, final_spb, stk_arg_assts) ->
410 -- The B-stack space for the pushed return addess, with any args pushed
411 -- on top, is recorded in final_spb.
413 -- Do the simultaneous assignments,
414 doSimAssts args_spa live_vars {-UNUSED: live_regs-}
415 (mkAbstractCs [pending_assts, node_asst, ret_asst,
416 reg_arg_assts, stk_arg_assts])
419 -- Final adjustment of stack pointers
420 adjustRealSps final_spa final_spb `thenC`
422 -- Now decide about semi-tagging
423 isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
424 case (semi_tagging_on, arg_amodes, node_points, sequel) of
427 -- *************** The semi-tagging case ***************
429 ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
431 -- Whoppee! Semi-tagging rules OK!
432 -- (a) semi-tagging is switched on
433 -- (b) there are no arguments,
434 -- (c) Node points to the closure
435 -- (d) we have a case-alternative sequel with
436 -- some visible alternatives
438 -- Why is test (c) necessary?
439 -- Usually Node will point to it at this point, because we're
440 -- scrutinsing something which is either a thunk or a
442 -- But not always! The example I came across is when we have
443 -- a top-level Double:
445 -- ... (case lit.3 of ...) ...
446 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
447 -- (OK, the simplifier should have eliminated this, but it's
448 -- easy to deal with the case anyway.)
450 join_details_to_code (load_regs_and_profiling_code, join_lbl)
451 = load_regs_and_profiling_code `mkAbsCStmts`
452 CJump (CLbl join_lbl CodePtrKind)
454 semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
455 join_details_to_code join_details)
456 | (tag, join_details) <- st_alts
460 -- Enter Node (we know infoptr will have the info ptr in it)!
462 CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
463 [CMacroExpr IntKind INFO_TAG [CReg infoptr]],
464 CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) ]
468 CAssign (CReg infoptr)
469 (CVal (NodeRel zeroOff) DataPtrKind),
471 case maybe_deflt_join_details of
473 CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
477 CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
478 [(mkMachInt 0, enter_jump)]
480 (CMacroExpr IntKind INFO_TAG [CReg infoptr])
482 (join_details_to_code details))
486 -- *************** The non-semi-tagging case ***************
488 other -> absC finish_code
492 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
494 loadRetAddrIntoRetReg InRetReg
495 = returnFC AbsCNop -- Return address already there
497 loadRetAddrIntoRetReg sequel
498 = sequelToAmode sequel `thenFC` \ amode ->
499 returnFC (CAssign (CReg RetReg) amode)
503 %************************************************************************
505 \subsection[doSimAssts]{@doSimAssts@}
507 %************************************************************************
509 @doSimAssts@ happens at the end of every block of code.
510 They are separate because we sometimes do some jiggery-pokery in between.
513 doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
514 -> PlainStgLiveVars -- Live in continuation
515 --UNUSED: -> [MagicId] -- Live regs (ptrs and non-ptrs)
519 doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
520 = -- Do the simultaneous assignments
521 absC (CSimultaneous sim_assts) `thenC`
523 -- Stub any unstubbed slots; the only live variables are indicated in
524 -- the end-of-block info in the monad
525 nukeDeadBindings live_vars `thenC`
526 getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
527 -- Passing in tail_spa here should actually be redundant, because
528 -- the stack should be trimmed (by nukeDeadBindings) to
529 -- exactly the tail_spa position anyhow.
531 -- Emit code to stub dead regs; this only generates actual
532 -- machine instructions in in the DEBUG version
533 -- *** NOT DONE YET ***
537 else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
538 mapCs stub_A_slot a_slots
541 stub_A_slot :: VirtualSpAOffset -> Code
542 stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
543 absC (CAssign (CVal spa_rel PtrKind)