[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / codeGen / CgTailCall.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 %********************************************************
5 %*                                                      *
6 \section[CgTailCall]{Tail calls: converting @StgApps@}
7 %*                                                      *
8 %********************************************************
9
10 \begin{code}
11 #include "HsVersions.h"
12
13 module CgTailCall (
14         cgTailCall,
15         performReturn,
16         mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
17         mkPrimReturnCode,
18         
19         tailCallBusiness,
20
21         -- and to make the interface self-sufficient...
22         StgAtom, Id, CgState, CAddrMode, TyCon,
23         CgInfoDownwards, HeapOffset, Maybe
24     ) where
25
26 IMPORT_Trace
27 import Pretty           -- Pretty/Outputable: rm (debugging only) ToDo
28 import Outputable
29
30 import StgSyn
31 import CgMonad
32 import AbsCSyn
33
34 import AbsUniType       ( isPrimType, UniType )
35 import CgBindery        ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
36 import CgCompInfo       ( oTHER_TAG, iND_TAG )
37 import CgRetConv        ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
38                           mkLiveRegsBitMask,
39                           CtrlReturnConvention(..), DataReturnConvention(..)
40                         )
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,
48                           ConTag(..)
49                         )
50 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
51 import PrimKind         ( retKindSize )
52 import Util
53 \end{code}
54
55 %************************************************************************
56 %*                                                                      *
57 \subsection[tailcall-doc]{Documentation}
58 %*                                                                      *
59 %************************************************************************
60
61 \begin{code}
62 cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
63 \end{code}
64
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.)
67
68 \begin{itemize}
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.
73 \end{itemize}
74
75 Things to be careful about:
76 \begin{itemize}
77 \item   Don't overwrite stack locations before you have finished with
78         them (remember you need the function and the as-yet-unmoved
79         arguments).
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.
83 \end{itemize}
84
85 Literals are similar to constructors; they return by putting
86 themselves in an appropriate register and returning to the address on
87 top of the B stack.
88
89 \begin{code}
90 cgTailCall (StgLitAtom lit) [] live_vars
91   = performPrimReturn (CLit lit) live_vars
92 \end{code}
93
94 Treat unboxed locals exactly like literals (above) except use the addr
95 mode for the local instead of (CLit lit) in the assignment.
96
97 Case for unboxed @Ids@ first:
98 \begin{code}
99 cgTailCall atom@(StgVarAtom fun) [] live_vars
100   | isPrimType (getIdUniType fun)
101   = getCAddrMode fun `thenFC` \ amode ->
102     performPrimReturn amode live_vars
103 \end{code}
104
105 The general case (@fun@ is boxed):
106 \begin{code}
107 cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
108 \end{code}
109
110 %************************************************************************
111 %*                                                                      *
112 \subsection[return-and-tail-call]{Return and tail call}
113 %*                                                                      *
114 %************************************************************************
115
116 ADR-HACK
117
118   A quick bit of hacking to try to solve my void#-leaking blues...
119
120   I think I'm getting bitten by this stuff because code like
121
122   \begin{pseudocode}
123           case ds.s12 :: IoWorld of {
124               -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
125             IoWorld ds.s13# -> ds.s13#;
126           } :: Universe#
127   \end{pseudocode}
128
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).
132
133 KCAH-RDA
134
135 \begin{code}
136 performPrimReturn :: CAddrMode  -- The thing to return
137                   -> PlainStgLiveVars
138                   -> Code
139
140 performPrimReturn amode live_vars
141   = let
142         kind = getAmodeKind amode
143         ret_reg = dataReturnConvPrim kind
144
145         assign_possibly = case kind of
146           VoidKind -> AbsCNop
147           kind -> (CAssign (CReg ret_reg) amode)
148     in
149     performReturn assign_possibly mkPrimReturnCode live_vars
150
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
157
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.
163
164 mkStaticAlgReturnCode :: Id             -- The constructor
165                       -> Maybe CLabel   -- The info ptr, if it isn't already set
166                       -> Sequel         -- where to return to
167                       -> Code
168
169 mkStaticAlgReturnCode con maybe_info_lbl sequel
170   =     -- Generate profiling code if necessary
171     (case return_convention of
172         VectoredReturn _ -> profCtrC SLIT("VEC_RETURN") []
173         other            -> nopC
174     )                                   `thenC`
175
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
181
182         UnvectoredReturn no_of_constrs
183          | no_of_constrs > 1
184                 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
185
186         other   -> nopC
187     )                                   `thenC`
188
189         -- Generate the right jump or return
190     (case sequel of
191         UpdateCode _ -> -- Ha!  We know the constructor,
192                         -- so we can go direct to the correct
193                         -- update code for that constructor
194
195                                 -- Set the info pointer, and jump
196                         set_info_ptr            `thenC`
197                         absC (CJump (CLbl update_label CodePtrKind))
198
199         CaseAlts _ (Just (alts, _)) ->  -- Ho! We know the constructor so
200                                         -- we can go right to the alternative
201
202                         -- No need to set info ptr when returning to a
203                         -- known join point. After all, the code at
204                         -- the destination knows what constructor it
205                         -- is going to handle.
206
207                         case assocMaybe alts tag of
208                            Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind))
209                            Nothing                   -> panic "mkStaticAlgReturnCode: default"
210                                 -- The Nothing case should never happen; it's the subject
211                                 -- of a wad of special-case code in cgReturnCon
212
213         other ->        -- OnStack, or (CaseAlts) ret_amode Nothing)
214                         -- Set the info pointer, and jump
215                     set_info_ptr                `thenC`
216                     sequelToAmode sequel        `thenFC` \ ret_amode ->
217                     absC (CReturn ret_amode return_info)
218     )
219
220   where
221     tag               = getDataConTag con
222     tycon             = getDataConTyCon con
223     return_convention = ctrlReturnConvAlg tycon
224     zero_indexed_tag  = tag - fIRST_TAG       -- Adjust tag to be zero-indexed
225                                               -- cf AbsCFuns.mkAlgAltsCSwitch
226
227     update_label      = case dataReturnConvAlg con of
228                             ReturnInHeap   -> mkStdUpdCodePtrVecLabel tycon tag
229                             ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
230
231     return_info = case return_convention of
232                         UnvectoredReturn _ -> DirectReturn
233                         VectoredReturn _   -> StaticVectoredReturn zero_indexed_tag
234
235     set_info_ptr = case maybe_info_lbl of
236                         Nothing       -> nopC
237                         Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind))
238
239
240 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
241
242 mkDynamicAlgReturnCode tycon dyn_tag sequel
243   = case ctrlReturnConvAlg tycon of
244         VectoredReturn _ ->     
245
246                 profCtrC SLIT("VEC_RETURN") []  `thenC`
247                 sequelToAmode sequel            `thenFC` \ ret_addr ->  
248                 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
249
250         UnvectoredReturn no_of_constrs ->
251
252                 -- Set tag if necessary
253                 -- This is done by a macro, because if we are short of registers
254                 -- we don't set TagReg; instead the continuation gets the tag
255                 -- by indexing off the info ptr
256                 (if no_of_constrs > 1 then
257                         absC (CMacroStmt SET_TAG [dyn_tag])
258                 else
259                         nopC
260                 )                       `thenC`
261
262
263                 sequelToAmode sequel            `thenFC` \ ret_addr ->
264                 -- Generate the right jump or return
265                 absC (CReturn ret_addr DirectReturn)
266 \end{code}
267
268 \begin{code}
269 performReturn :: AbstractC          -- Simultaneous assignments to perform
270               -> (Sequel -> Code)   -- The code to execute to actually do
271                                     -- the return, given an addressing mode
272                                     -- for the return address
273               -> PlainStgLiveVars
274               -> Code
275
276 performReturn sim_assts finish_code live_vars
277   = getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
278
279         -- Do the simultaneous assignments,
280     doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts        `thenC`
281
282         -- Adjust stack pointers
283     adjustRealSps args_spa args_spb     `thenC`
284
285         -- Do the return
286     finish_code sequel          -- "sequel" is `robust' in that it doesn't
287                                 -- depend on stk-ptr values
288 -- where
289 --UNUSED:    live_regs = getDestinationRegs sim_assts
290           -- ToDo: this is a *really* boring way to compute the
291           -- live-reg set!
292 \end{code}
293
294 \begin{code}
295 performTailCall :: Id                   -- Function
296                 -> [PlainStgAtom]       -- Args
297                 -> PlainStgLiveVars
298                 -> Code
299
300 performTailCall fun args live_vars
301   =     -- Get all the info we have about the function and args and go on to
302         -- the business end
303     getCAddrModeAndInfo fun     `thenFC` \ (fun_amode, lf_info) ->
304     getAtomAmodes args          `thenFC` \ arg_amodes ->
305
306     tailCallBusiness
307                 fun fun_amode lf_info arg_amodes
308                 live_vars AbsCNop {- No pending assignments -}
309
310
311 tailCallBusiness :: Id -> CAddrMode     -- Function and its amode
312                  -> LambdaFormInfo      -- Info about the function
313                  -> [CAddrMode]         -- Arguments
314                  -> PlainStgLiveVars    -- Live in continuation
315
316                  -> AbstractC           -- Pending simultaneous assignments
317                                         -- *** GUARANTEED to contain only stack assignments.
318                                         --     In ptic, we don't need to look in here to
319                                         --     discover all live regs
320
321                  -> Code
322
323 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
324   = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_TAILCALL") IntKind]  `thenC`
325
326     isSwitchSetC EmitArityChecks                `thenFC` \ do_arity_chks ->
327
328     nodeMustPointToIt lf_info                   `thenFC` \ node_points ->
329     getEntryConvention fun lf_info
330         (map getAmodeKind arg_amodes)           `thenFC` \ entry_conv ->
331
332     getEndOfBlockInfo   `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
333
334     let
335         node_asst
336           = if node_points then
337                 CAssign (CReg node) fun_amode
338             else
339                 AbsCNop
340
341         (arg_regs, finish_code)
342           = case entry_conv of
343               ViaNode                     ->
344                 ([],
345                      mkAbstractCs [
346                         CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
347                         CAssign (CReg infoptr)
348
349                                 (CMacroExpr DataPtrKind INFO_PTR [CReg node]),
350                         CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
351                      ])
352               StdEntry lbl Nothing        -> ([], CJump (CLbl lbl CodePtrKind))
353               StdEntry lbl (Just itbl)    -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
354                                                      `mkAbsCStmts`
355                                                   CJump (CLbl lbl CodePtrKind))
356               DirectEntry lbl arity regs  ->
357                 (regs,   (if do_arity_chks
358                           then CMacroStmt SET_ARITY [mkIntCLit arity]
359                           else AbsCNop)
360                          `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
361
362         no_of_args = length arg_amodes
363
364 {- UNUSED:      live_regs = if node_points then
365                         node : arg_regs
366                     else
367                         arg_regs
368 -}
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
372                                                            -- args beyond arity
373
374         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
375
376     in
377     case fun_amode of
378       CJoinPoint join_spa join_spb ->  -- Ha!  A let-no-escape thingy
379
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
385               -- when it finishes.
386
387           mkStkAmodes join_spa join_spb stk_arg_amodes
388                       `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
389
390                 -- Do the simultaneous assignments,
391           doSimAssts join_spa live_vars {-UNUSED: live_regs-}
392                 (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
393                         `thenC`
394
395                 -- Adjust stack ptrs
396           adjustRealSps final_spa final_spb     `thenC`
397
398                 -- Jump to join point
399           absC finish_code
400
401       _ -> -- else: not a let-no-escape (the common case)
402
403                 -- Make instruction to save return address
404             loadRetAddrIntoRetReg sequel        `thenFC` \ ret_asst ->
405                 
406             mkStkAmodes args_spa args_spb stk_arg_amodes
407                                                 `thenFC`
408                             \ (final_spa, final_spb, stk_arg_assts) ->
409
410                 -- The B-stack space for the pushed return addess, with any args pushed
411                 -- on top, is recorded in final_spb.
412
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])
417                                                 `thenC`
418
419                 -- Final adjustment of stack pointers
420             adjustRealSps final_spa final_spb   `thenC`
421
422                 -- Now decide about semi-tagging
423             isSwitchSetC DoSemiTagging          `thenFC` \ semi_tagging_on ->
424             case (semi_tagging_on, arg_amodes, node_points, sequel) of
425
426         --
427         -- *************** The semi-tagging case ***************
428         --
429               (   True,            [],          True,        CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
430
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
437
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
441                 -- constructor.
442                 -- But not always!  The example I came across is when we have
443                 -- a top-level Double:
444                 --      lit.3 = D# 3.000
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.)
449
450
451                 let
452                     join_details_to_code (load_regs_and_profiling_code, join_lbl)
453                         = load_regs_and_profiling_code          `mkAbsCStmts`
454                           CJump (CLbl join_lbl CodePtrKind)
455
456                     semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
457                                           join_details_to_code join_details)
458                                        | (tag, join_details) <- st_alts
459                                        ]
460
461                         -- This alternative is for the unevaluated case; oTHER_TAG is -1
462                     un_evald_alt = (mkMachInt oTHER_TAG, enter_jump)
463
464                     enter_jump = CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
465                       -- Enter Node (we know infoptr will have the info ptr in it)!
466
467                 in
468
469                         -- Final switch
470                 absC (mkAbstractCs [
471                             CAssign (CReg infoptr)
472                                     (CVal (NodeRel zeroOff) DataPtrKind),
473
474                             case maybe_deflt_join_details of
475                                 Nothing ->
476                                     CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
477                                         (semi_tagged_alts)
478                                         (enter_jump)
479                                 Just (_, details) ->
480                                     CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
481                                      [(mkMachInt 0, enter_jump)]
482                                      (CSwitch
483                                          (CMacroExpr IntKind INFO_TAG [CReg infoptr])
484                                          (semi_tagged_alts)
485                                          (join_details_to_code details))
486                 ])
487
488         --
489         -- *************** The non-semi-tagging case ***************
490         --
491               other -> absC finish_code
492 \end{code}
493
494 \begin{code}
495 loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
496
497 loadRetAddrIntoRetReg InRetReg
498   = returnFC AbsCNop  -- Return address already there
499
500 loadRetAddrIntoRetReg sequel
501   = sequelToAmode sequel      `thenFC` \ amode ->
502     returnFC (CAssign (CReg RetReg) amode)
503
504 \end{code}
505
506 %************************************************************************
507 %*                                                                      *
508 \subsection[doSimAssts]{@doSimAssts@}
509 %*                                                                      *
510 %************************************************************************
511
512 @doSimAssts@ happens at the end of every block of code.
513 They are separate because we sometimes do some jiggery-pokery in between.
514
515 \begin{code}
516 doSimAssts :: VirtualSpAOffset  -- tail_spa: SpA as seen by continuation
517            -> PlainStgLiveVars  -- Live in continuation
518 --UNUSED:  -> [MagicId]         -- Live regs (ptrs and non-ptrs)
519            -> AbstractC
520            -> Code
521
522 doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
523   =     -- Do the simultaneous assignments
524     absC (CSimultaneous sim_assts)      `thenC`
525
526         -- Stub any unstubbed slots; the only live variables are indicated in
527         -- the end-of-block info in the monad
528     nukeDeadBindings live_vars          `thenC`
529     getUnstubbedAStackSlots tail_spa    `thenFC` \ a_slots ->
530         -- Passing in tail_spa here should actually be redundant, because
531         -- the stack should be trimmed (by nukeDeadBindings) to
532         -- exactly the tail_spa position anyhow.
533
534         -- Emit code to stub dead regs; this only generates actual
535         -- machine instructions in in the DEBUG version
536         -- *** NOT DONE YET ***
537
538     (if (null a_slots)
539      then nopC
540      else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)]      `thenC`
541           mapCs stub_A_slot a_slots
542     )
543   where
544     stub_A_slot :: VirtualSpAOffset -> Code
545     stub_A_slot offset = getSpARelOffset offset         `thenFC` \ spa_rel ->
546                          absC (CAssign  (CVal spa_rel PtrKind)
547                                         (CReg StkStubReg))
548 \end{code}