[project @ 1999-01-21 10:31:41 by simonm]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgTailCall.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 % $Id: CgTailCall.lhs,v 1.18 1999/01/21 10:31:57 simonm Exp $
5 %
6 %********************************************************
7 %*                                                      *
8 \section[CgTailCall]{Tail calls: converting @StgApps@}
9 %*                                                      *
10 %********************************************************
11
12 \begin{code}
13 module CgTailCall (
14         cgTailCall,
15         performReturn, performPrimReturn,
16         mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
17         mkUnboxedTupleReturnCode, returnUnboxedTuple,
18         mkPrimReturnCode,
19
20         tailCallFun,
21         tailCallPrimOp,
22         doTailCall,
23
24         pushReturnAddress
25     ) where
26
27 #include "HsVersions.h"
28
29 import CgMonad
30 import AbsCSyn
31
32 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
33 import CgBindery        ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
34 import CgRetConv        ( dataReturnConvPrim,
35                           ctrlReturnConvAlg, CtrlReturnConvention(..),
36                           assignAllRegs, assignRegs
37                         )
38 import CgStackery       ( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
39 import CgUsages         ( getSpRelOffset )
40 import CgUpdate         ( pushSeqFrame )
41 import CLabel           ( mkUpdEntryLabel, mkRtsPrimOpLabel )
42 import ClosureInfo      ( nodeMustPointToIt,
43                           getEntryConvention, EntryConvention(..),
44                           LambdaFormInfo
45                         )
46 import CmdLineOpts      ( opt_DoSemiTagging )
47 import Id               ( Id, idType, idName )
48 import DataCon          ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
49 import Const            ( mkMachInt )
50 import Maybes           ( assocMaybe )
51 import PrimRep          ( PrimRep(..) )
52 import StgSyn           ( StgArg, GenStgArg(..) )
53 import Type             ( isUnLiftedType )
54 import TyCon            ( TyCon )
55 import PrimOp           ( PrimOp )
56 import Util             ( zipWithEqual )
57 import Outputable
58 import Panic            ( panic, assertPanic )
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63 \subsection[tailcall-doc]{Documentation}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 cgTailCall :: Id -> [StgArg] -> Code
69 \end{code}
70
71 Here's the code we generate for a tail call.  (NB there may be no
72 arguments, in which case this boils down to just entering a variable.)
73
74 \begin{itemize}
75 \item   Adjust the stack ptr to \tr{tailSp + #args}.
76 \item   Put args in the top locations of the resulting stack.
77 \item   Make Node point to the function closure.
78 \item   Enter the function closure.
79 \end{itemize}
80
81 Things to be careful about:
82 \begin{itemize}
83 \item   Don't overwrite stack locations before you have finished with
84         them (remember you need the function and the as-yet-unmoved
85         arguments).
86 \item   Preferably, generate no code to replace x by x on the stack (a
87         common situation in tail-recursion).
88 \item   Adjust the stack high water mark appropriately.
89 \end{itemize}
90
91 Treat unboxed locals exactly like literals (above) except use the addr
92 mode for the local instead of (CLit lit) in the assignment.
93
94 Case for unboxed @Ids@ first:
95 \begin{code}
96 cgTailCall fun []
97   | isUnLiftedType (idType fun)
98   = getCAddrMode fun            `thenFC` \ amode ->
99     performPrimReturn (ppr fun) amode
100 \end{code}
101
102 The general case (@fun@ is boxed):
103 \begin{code}
104 cgTailCall fun args = performTailCall fun args
105 \end{code}
106
107 %************************************************************************
108 %*                                                                      *
109 \subsection[return-and-tail-call]{Return and tail call}
110 %*                                                                      *
111 %************************************************************************
112
113 \begin{code}
114 performPrimReturn :: SDoc       -- Just for debugging (sigh)
115                   -> CAddrMode  -- The thing to return
116                   -> Code
117
118 performPrimReturn doc amode
119   = let
120         kind = getAmodeRep amode
121         ret_reg = dataReturnConvPrim kind
122
123         assign_possibly = case kind of
124           VoidRep -> AbsCNop
125           kind -> (CAssign (CReg ret_reg) amode)
126     in
127     performReturn assign_possibly (mkPrimReturnCode doc)
128
129 mkPrimReturnCode :: SDoc                -- Debugging only
130                  -> Sequel
131                  -> Code
132 mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc
133 mkPrimReturnCode doc sequel     = sequelToAmode sequel  `thenFC` \ dest_amode ->
134                                   absC (CReturn dest_amode DirectReturn)
135                                   -- Direct, no vectoring
136
137 -- Constructor is built on the heap; Node is set.
138 -- All that remains is
139 --      (a) to set TagReg, if necessary
140 --      (c) to do the right sort of jump.
141
142 mkStaticAlgReturnCode :: DataCon        -- The constructor
143                       -> Sequel         -- where to return to
144                       -> Code
145
146 mkStaticAlgReturnCode con sequel
147   =     -- Generate profiling code if necessary
148     (case return_convention of
149         VectoredReturn sz -> profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz]
150         other             -> nopC
151     )                                   `thenC`
152
153         -- Set tag if necessary
154         -- This is done by a macro, because if we are short of registers
155         -- we don't set TagReg; instead the continuation gets the tag
156         -- by indexing off the info ptr
157     (case return_convention of
158
159         UnvectoredReturn no_of_constrs
160          | no_of_constrs > 1
161                 -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
162
163         other   -> nopC
164     )                                   `thenC`
165
166         -- Generate the right jump or return
167     (case sequel of
168         UpdateCode ->   -- Ha!  We can go direct to the update code,
169                         -- (making sure to jump to the *correct* update
170                         --  code.)
171                         absC (CReturn (CLbl mkUpdEntryLabel CodePtrRep)
172                                       return_info)
173
174         CaseAlts _ (Just (alts, _)) ->  -- Ho! We know the constructor so
175                                         -- we can go right to the alternative
176
177                 case assocMaybe alts tag of
178                    Just (alt_absC, join_lbl) -> 
179                         absC (CJump (CLbl join_lbl CodePtrRep))
180                    Nothing -> panic "mkStaticAlgReturnCode: default"
181                                 -- The Nothing case should never happen; 
182                                 -- it's the subject of a wad of special-case 
183                                 -- code in cgReturnCon
184
185         -- can't be a SeqFrame, because we're returning a constructor
186
187         other ->        -- OnStack, or (CaseAlts ret_amode Nothing)
188                     sequelToAmode sequel        `thenFC` \ ret_amode ->
189                     absC (CReturn ret_amode return_info)
190     )
191
192   where
193     tag               = dataConTag   con
194     tycon             = dataConTyCon con
195     return_convention = ctrlReturnConvAlg tycon
196     zero_indexed_tag  = tag - fIRST_TAG       -- Adjust tag to be zero-indexed
197                                               -- cf AbsCUtils.mkAlgAltsCSwitch
198
199     return_info = 
200        case return_convention of
201                 UnvectoredReturn _ -> DirectReturn
202                 VectoredReturn _   -> StaticVectoredReturn zero_indexed_tag
203
204 mkUnboxedTupleReturnCode :: Sequel -> Code
205 mkUnboxedTupleReturnCode sequel
206     = case sequel of
207         -- can't update with an unboxed tuple!
208         UpdateCode -> panic "mkUnboxedTupleReturnCode"
209
210         CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) ->
211                         absC (CJump (CLbl join_lbl CodePtrRep))
212
213         -- can't be a SeqFrame
214
215         other ->        -- OnStack, or (CaseAlts ret_amode something)
216                     sequelToAmode sequel        `thenFC` \ ret_amode ->
217                     absC (CReturn ret_amode DirectReturn)
218
219 -- This function is used by PrimOps that return enumerated types (i.e.
220 -- all the comparison operators).
221
222 mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
223
224 mkDynamicAlgReturnCode tycon dyn_tag sequel
225   = case ctrlReturnConvAlg tycon of
226         VectoredReturn sz ->
227
228                 profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
229                 sequelToAmode sequel            `thenFC` \ ret_addr ->
230                 absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
231
232         UnvectoredReturn no_of_constrs ->
233
234                 -- Set tag if necessary
235                 -- This is done by a macro, because if we are short of registers
236                 -- we don't set TagReg; instead the continuation gets the tag
237                 -- by indexing off the info ptr
238                 (if no_of_constrs > 1 then
239                         absC (CMacroStmt SET_TAG [dyn_tag])
240                 else
241                         nopC
242                 )                       `thenC`
243
244
245                 sequelToAmode sequel            `thenFC` \ ret_addr ->
246                 -- Generate the right jump or return
247                 absC (CReturn ret_addr DirectReturn)
248 \end{code}
249
250 \begin{code}
251 performReturn :: AbstractC          -- Simultaneous assignments to perform
252               -> (Sequel -> Code)   -- The code to execute to actually do
253                                     -- the return, given an addressing mode
254                                     -- for the return address
255               -> Code
256
257 -- this is just a special case of doTailCall, later.
258 performReturn sim_assts finish_code
259   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
260
261         -- Do the simultaneous assignments,
262     doSimAssts sim_assts                `thenC`
263
264         -- push a return address if necessary
265         -- (after the assignments above, in case we clobber a live
266         --  stack location)
267     pushReturnAddress eob               `thenC`
268
269         -- Adjust stack pointer
270     adjustRealSp args_sp                `thenC`
271
272         -- Do the return
273     finish_code sequel          -- "sequel" is `robust' in that it doesn't
274                                 -- depend on stk-ptr values
275 \end{code}
276
277 Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
278 we want to do things in a slightly different order to normal:
279
280                 - push return address
281                 - adjust stack pointer
282                 - r = call(args...)
283                 - assign regs for unboxed tuple (usually just R1 = r)
284                 - return to continuation
285
286 The return address (i.e. stack frame) must be on the stack before
287 doing the call in case the call ends up in the garbage collector.
288
289 Sadly, the information about the continuation is lost after we push it
290 (in order to avoid pushing it again), so we end up doing a needless
291 indirect jump (ToDo).
292
293 \begin{code}
294 returnUnboxedTuple :: [CAddrMode] -> Code -> Code
295 returnUnboxedTuple amodes before_jump
296   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
297
298         -- push a return address if necessary
299     pushReturnAddress eob               `thenC`
300     setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
301
302         -- Adjust stack pointer
303     adjustRealSp args_sp                `thenC`
304
305     before_jump                         `thenC`
306
307     let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
308     in
309
310     profCtrC SLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
311
312     doTailCall amodes ret_regs
313                 mkUnboxedTupleReturnCode
314                 (length leftovers)  {- fast args arity -}
315                 AbsCNop {-no pending assigments-}
316                 Nothing {-not a let-no-escape-}
317                 False   {-node doesn't point-}
318      )
319 \end{code}
320
321 \begin{code}
322 performTailCall :: Id           -- Function
323                 -> [StgArg]     -- Args
324                 -> Code
325
326 performTailCall fun args
327   =     -- Get all the info we have about the function and args and go on to
328         -- the business end
329     getCAddrModeAndInfo fun     `thenFC` \ (fun_amode, lf_info) ->
330     getArgAmodes args           `thenFC` \ arg_amodes ->
331
332     tailCallFun
333                 fun fun_amode lf_info arg_amodes
334                 AbsCNop {- No pending assignments -}
335
336
337 -- generating code for a tail call to a function (or closure)
338
339 tailCallFun :: Id -> CAddrMode  -- Function and its amode
340                  -> LambdaFormInfo      -- Info about the function
341                  -> [CAddrMode]         -- Arguments
342
343                  -> AbstractC           -- Pending simultaneous assignments
344                                         -- *** GUARANTEED to contain only stack 
345                                         -- assignments.
346
347                                         -- In ptic, we don't need to look in 
348                                         -- here to discover all live regs
349
350                  -> Code
351
352 tailCallFun fun fun_amode lf_info arg_amodes pending_assts
353   = nodeMustPointToIt lf_info                   `thenFC` \ node_points ->
354     getEntryConvention (idName fun) lf_info
355         (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
356     let
357         node_asst
358           = if node_points then
359                 CAssign (CReg node) fun_amode
360             else
361                 AbsCNop
362
363         (arg_regs, finish_code, arity)
364           = case entry_conv of
365               ViaNode ->
366                 ([],
367                      profCtrC SLIT("TICK_ENT_VIA_NODE") [] `thenC`
368                      absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE 
369                                 [CVal (nodeRel 0) DataPtrRep]))
370                      , 0)
371               StdEntry lbl -> ([], absC (CJump (CLbl lbl CodePtrRep)), 0)
372               DirectEntry lbl arity regs  ->
373                 (regs,   absC (CJump (CLbl lbl CodePtrRep)), 
374                  arity - length regs)
375
376         -- set up for a let-no-escape if necessary
377         join_sp = case fun_amode of
378                         CJoinPoint sp -> Just sp
379                         other         -> Nothing
380     in
381     doTailCall arg_amodes arg_regs (const finish_code) arity
382                 (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
383
384
385 -- this generic tail call code is used for both function calls and returns.
386
387 doTailCall 
388         :: [CAddrMode]                  -- args to pass to function
389         -> [MagicId]                    -- registers to use
390         -> (Sequel->Code)               -- code to perform jump
391         -> Int                          -- number of "fast" stack arguments
392         -> AbstractC                    -- pending assignments
393         -> Maybe VirtualSpOffset        -- sp offset to trim stack to
394         -> Bool                         -- node points to the closure to enter
395         -> Code
396
397 doTailCall arg_amodes arg_regs finish_code arity pending_assts
398                 maybe_join_sp node_points
399   = getEndOfBlockInfo   `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
400
401     let
402         no_of_args = length arg_amodes
403
404         (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
405             -- We get some stk_arg_amodes if (a) no regs, or 
406             --                               (b) args beyond arity
407
408         reg_arg_assts
409           = mkAbstractCs (zipWithEqual "assign_to_reg2" 
410                                 assign_to_reg arg_regs reg_arg_amodes)
411
412         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
413
414         join_sp = case maybe_join_sp of
415                         Just sp -> ASSERT(not (args_sp > sp)) sp
416               -- If ASSERTion fails: Oops: the join point has *lower*
417               -- stack ptrs than the continuation Note that we take
418               -- the Sp point without the return address here.   The
419               -- return address is put on by the let-no-escapey thing
420               -- when it finishes.
421                         Nothing -> args_sp
422
423         (fast_stk_amodes, tagged_stk_amodes) = 
424                 splitAt arity stk_arg_amodes
425     in
426         -- We can omit tags on the arguments passed to the fast entry point, 
427         -- but we have to be careful to fill in the tags on any *extra*
428         -- arguments we're about to push on the stack.
429
430         mkTaggedStkAmodes join_sp tagged_stk_amodes `thenFC`
431                             \ (fast_sp, tagged_arg_assts, tag_assts) ->
432
433         mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
434                             \ (final_sp, fast_arg_assts, _) ->
435
436         -- adjust the high-water mark if necessary
437         adjustStackHW final_sp  `thenC`
438
439                 -- The stack space for the pushed return addess, 
440                 -- with any args pushed on top, is recorded in final_sp.
441         
442                 -- Do the simultaneous assignments,
443         doSimAssts (mkAbstractCs [pending_assts,
444                                   reg_arg_assts, 
445                                   fast_arg_assts, 
446                                   tagged_arg_assts,
447                                   tag_assts])   `thenC`
448         
449                 -- push a return address if necessary
450                 -- (after the assignments above, in case we clobber a live
451                 --  stack location)
452         pushReturnAddress eob           `thenC`
453
454                 -- Final adjustment of stack pointer
455         adjustRealSp final_sp           `thenC`
456         
457                 -- Now decide about semi-tagging
458         let
459                 semi_tagging_on = opt_DoSemiTagging
460         in
461         case (semi_tagging_on, arg_amodes, node_points, sequel) of
462
463         --
464         -- *************** The semi-tagging case ***************
465         --
466         {- XXX leave this out for now.
467               (   True,            [],          True,        CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
468
469                 -- Whoppee!  Semi-tagging rules OK!
470                 -- (a) semi-tagging is switched on
471                 -- (b) there are no arguments,
472                 -- (c) Node points to the closure
473                 -- (d) we have a case-alternative sequel with
474                 --      some visible alternatives
475
476                 -- Why is test (c) necessary?
477                 -- Usually Node will point to it at this point, because we're
478                 -- scrutinsing something which is either a thunk or a
479                 -- constructor.
480                 -- But not always!  The example I came across is when we have
481                 -- a top-level Double:
482                 --      lit.3 = D# 3.000
483                 --      ... (case lit.3 of ...) ...
484                 -- Here, lit.3 is built as a re-entrant thing, which you must enter.
485                 -- (OK, the simplifier should have eliminated this, but it's
486                 --  easy to deal with the case anyway.)
487                 let
488                     join_details_to_code (load_regs_and_profiling_code, join_lbl)
489                         = load_regs_and_profiling_code          `mkAbsCStmts`
490                           CJump (CLbl join_lbl CodePtrRep)
491
492                     semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
493                                           join_details_to_code join_details)
494                                        | (tag, join_details) <- st_alts
495                                        ]
496
497                     enter_jump
498                       -- Enter Node (we know infoptr will have the info ptr in it)!
499                       = mkAbstractCs [
500                         CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
501                                         [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
502                         CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
503                 in
504                         -- Final switch
505                 absC (mkAbstractCs [
506                             CAssign (CReg infoptr)
507                                     (CVal (NodeRel zeroOff) DataPtrRep),
508
509                             case maybe_deflt_join_details of
510                                 Nothing ->
511                                     CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
512                                         (semi_tagged_alts)
513                                         (enter_jump)
514                                 Just (_, details) ->
515                                     CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
516                                      [(mkMachInt 0, enter_jump)]
517                                      (CSwitch
518                                          (CMacroExpr IntRep INFO_TAG [CReg infoptr])
519                                          (semi_tagged_alts)
520                                          (join_details_to_code details))
521                 ])
522                 -}
523
524         --
525         -- *************** The non-semi-tagging case ***************
526         --
527               other -> finish_code sequel
528 \end{code}
529
530 %************************************************************************
531 %*                                                                      *
532 \subsection[tailCallPrimOp]{@tailCallPrimOp@}
533 %*                                                                      *
534 %************************************************************************
535
536 \begin{code}
537 tailCallPrimOp :: PrimOp -> [StgArg] -> Code
538 tailCallPrimOp op args =
539     -- we're going to perform a normal-looking tail call, 
540     -- except that *all* the arguments will be in registers.
541     getArgAmodes args           `thenFC` \ arg_amodes ->
542     let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
543     in
544     ASSERT(null leftovers) -- no stack-resident args
545     doTailCall arg_amodes arg_regs 
546         (const (absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))))
547         0       {- arity shouldn't matter, all args in regs -}
548         AbsCNop {- no pending assignments -}
549         Nothing {- not a let-no-escape -}
550         False   {- node doesn't point -}
551 \end{code}
552
553 %************************************************************************
554 %*                                                                      *
555 \subsection[doSimAssts]{@doSimAssts@}
556 %*                                                                      *
557 %************************************************************************
558
559 @doSimAssts@ happens at the end of every block of code.
560 They are separate because we sometimes do some jiggery-pokery in between.
561
562 \begin{code}
563 doSimAssts :: AbstractC -> Code
564
565 doSimAssts sim_assts
566   = absC (CSimultaneous sim_assts)
567 \end{code}
568
569 %************************************************************************
570 %*                                                                      *
571 \subsection[retAddr]{@Return Addresses@}
572 %*                                                                      *
573 %************************************************************************
574
575 We always push the return address just before performing a tail call
576 or return.  The reason we leave it until then is because the stack
577 slot that the return address is to go into might contain something
578 useful.
579
580 If the end of block info is CaseAlts, then we're in the scrutinee of a
581 case expression and the return address is still to be pushed.
582
583 There are cases where it doesn't look necessary to push the return
584 address: for example, just before doing a return to a known
585 continuation.  However, the continuation will expect to find the
586 return address on the stack in case it needs to do a heap check.
587
588 \begin{code}
589 pushReturnAddress :: EndOfBlockInfo -> Code
590 pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _)) =
591     getSpRelOffset args_sp                       `thenFC` \ sp_rel ->
592     absC (CAssign (CVal sp_rel RetRep) amode)
593 pushReturnAddress (EndOfBlockInfo args_sp sequel@(SeqFrame amode _)) =
594     pushSeqFrame args_sp                         `thenFC` \ ret_sp ->
595     getSpRelOffset ret_sp                        `thenFC` \ sp_rel ->
596     absC (CAssign (CVal sp_rel RetRep) amode)
597 pushReturnAddress _ = nopC
598 \end{code}