Some alpha renaming
[ghc.git] / compiler / codeGen / CgTailCall.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 % Code generation for tail calls.
6
7 \begin{code}
8 {-# OPTIONS -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
13 -- for details
14
15 module CgTailCall (
16         cgTailCall, performTailCall,
17         performReturn, performPrimReturn,
18         returnUnboxedTuple, ccallReturnUnboxedTuple,
19         pushUnboxedTuple,
20         tailCallPrimOp,
21         tailCallPrimCall,
22
23         pushReturnAddress
24     ) where
25
26 #include "HsVersions.h"
27
28 import CgMonad
29 import CgBindery
30 import CgInfoTbls
31 import CgCallConv
32 import CgStackery
33 import CgHeapery
34 import CgUtils
35 import CgTicky
36 import ClosureInfo
37 import OldCmm   
38 import OldCmmUtils
39 import CLabel
40 import Type
41 import Id
42 import StgSyn
43 import PrimOp
44 import DynFlags
45 import Outputable
46 import Util
47
48 import Control.Monad
49 import Data.Maybe
50
51 -----------------------------------------------------------------------------
52 -- Tail Calls
53
54 cgTailCall :: Id -> [StgArg] -> Code
55
56 -- Here's the code we generate for a tail call.  (NB there may be no
57 -- arguments, in which case this boils down to just entering a variable.)
58 -- 
59 --    * Put args in the top locations of the stack.
60 --    * Adjust the stack ptr
61 --    * Make R1 point to the function closure if necessary.
62 --    * Perform the call.
63 --
64 -- Things to be careful about:
65 --
66 --    * Don't overwrite stack locations before you have finished with
67 --      them (remember you need the function and the as-yet-unmoved
68 --      arguments).
69 --    * Preferably, generate no code to replace x by x on the stack (a
70 --      common situation in tail-recursion).
71 --    * Adjust the stack high water mark appropriately.
72 -- 
73 -- Treat unboxed locals exactly like literals (above) except use the addr
74 -- mode for the local instead of (CLit lit) in the assignment.
75
76 cgTailCall fun args
77   = do  { fun_info <- getCgIdInfo fun
78
79         ; if isUnLiftedType (idType fun)
80           then  -- Primitive return
81                 ASSERT( null args )
82             do  { fun_amode <- idInfoToAmode fun_info
83                 ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } 
84
85           else -- Normal case, fun is boxed
86             do  { arg_amodes <- getArgAmodes args
87                 ; performTailCall fun_info arg_amodes noStmts }
88         }
89                 
90
91 -- -----------------------------------------------------------------------------
92 -- The guts of a tail-call
93
94 performTailCall 
95         :: CgIdInfo             -- The function
96         -> [(CgRep,CmmExpr)]    -- Args
97         -> CmmStmts             -- Pending simultaneous assignments
98                                 --  *** GUARANTEED to contain only stack assignments.
99         -> Code
100
101 performTailCall fun_info arg_amodes pending_assts
102   | Just join_sp <- maybeLetNoEscape fun_info
103   =        -- A let-no-escape is slightly different, because we
104            -- arrange the stack arguments into pointers and non-pointers
105            -- to make the heap check easier.  The tail-call sequence
106            -- is very similar to returning an unboxed tuple, so we
107            -- share some code.
108      do { dflags <- getDynFlags
109         ; (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes
110         ; emitSimultaneously (pending_assts `plusStmts` arg_assts)
111         ; let lbl = enterReturnPtLabel dflags (idUnique (cgIdInfoId fun_info))
112         ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) }
113
114   | otherwise
115   = do  { fun_amode <- idInfoToAmode fun_info
116         ; dflags <- getDynFlags
117         ; let assignSt  = CmmAssign nodeReg fun_amode
118               node_asst = oneStmt assignSt
119               node_live = Just [node]
120               (opt_node_asst, opt_node_live)
121                       | nodeMustPointToIt dflags lf_info = (node_asst, node_live)
122                       | otherwise                 = (noStmts, Just [])
123         ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
124
125         ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
126
127             -- Node must always point to things we enter
128             EnterIt -> do
129                 { emitSimultaneously (node_asst `plusStmts` pending_assts) 
130                 ; let target       = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
131                       enterClosure = stmtC (CmmJump target node_live)
132                       -- If this is a scrutinee
133                       -- let's check if the closure is a constructor
134                       -- so we can directly jump to the alternatives switch
135                       -- statement.
136                       jumpInstr = getEndOfBlockInfo >>=
137                                   maybeSwitchOnCons dflags enterClosure
138                 ; doFinalJump sp False jumpInstr }
139     
140             -- A function, but we have zero arguments.  It is already in WHNF,
141             -- so we can just return it.  
142             -- As with any return, Node must point to it.
143             ReturnIt -> do
144                 { emitSimultaneously (node_asst `plusStmts` pending_assts)
145                 ; doFinalJump sp False $ emitReturnInstr node_live }
146     
147             -- A real constructor.  Don't bother entering it, 
148             -- just do the right sort of return instead.
149             -- As with any return, Node must point to it.
150             ReturnCon _ -> do
151                 { emitSimultaneously (node_asst `plusStmts` pending_assts)
152                 ; doFinalJump sp False $ emitReturnInstr node_live }
153
154             JumpToIt lbl -> do
155                 { emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
156                 ; doFinalJump sp False $ jumpToLbl lbl opt_node_live }
157     
158             -- A slow function call via the RTS apply routines
159             -- Node must definitely point to the thing
160             SlowCall -> do 
161                 {  when (not (null arg_amodes)) $ do
162                    { if (isKnownFun lf_info) 
163                         then tickyKnownCallTooFewArgs
164                         else tickyUnknownCall
165                    ; tickySlowCallPat (map fst arg_amodes) 
166                    }
167
168                 ; let (apply_lbl, args, extra_args) 
169                         = constructSlowCall arg_amodes
170
171                 ; directCall sp apply_lbl args extra_args node_live
172                         (node_asst `plusStmts` pending_assts)
173
174                 }
175     
176             -- A direct function call (possibly with some left-over arguments)
177             DirectEntry lbl arity -> do
178                 { if arity == length arg_amodes
179                         then tickyKnownCallExact
180                         else do tickyKnownCallExtraArgs
181                                 tickySlowCallPat (map fst (drop arity arg_amodes))
182
183                 ; let
184                      -- The args beyond the arity go straight on the stack
185                      (arity_args, extra_args) = splitAt arity arg_amodes
186      
187                 ; directCall sp lbl arity_args extra_args opt_node_live
188                         (opt_node_asst `plusStmts` pending_assts)
189                 }
190         }
191   where
192     fun_id    = cgIdInfoId fun_info
193     fun_name  = idName fun_id
194     lf_info   = cgIdInfoLF fun_info
195     fun_has_cafs = idCafInfo fun_id
196     untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg))
197     -- Test if closure is a constructor
198     maybeSwitchOnCons dflags enterClosure eob
199               | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
200                 not (gopt Opt_SccProfilingOn dflags)
201                 -- we can't shortcut when profiling is on, because we have
202                 -- to enter a closure to mark it as "used" for LDV profiling
203               = do { is_constr <- newLabelC
204                    -- Is the pointer tagged?
205                    -- Yes, jump to switch statement
206                    ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) 
207                                 is_constr)
208                    -- No, enter the closure.
209                    ; enterClosure
210                    ; labelC is_constr
211                    ; stmtC (CmmJump (entryCode dflags $
212                                CmmLit (CmmLabel lbl)) (Just [node]))
213                    }
214 {-
215               -- This is a scrutinee for a case expression
216               -- so let's see if we can directly inspect the closure
217               | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob
218               = do { no_cons <- newLabelC
219                    -- Both the NCG and gcc optimize away the temp
220                    ; z <- newTemp  wordRep
221                    ; stmtC (CmmAssign z tag_expr)
222                    ; let tag = CmmReg z
223                    -- Is the closure a cons?
224                    ; stmtC (CmmCondBranch (cond1 tag) no_cons)
225                    ; stmtC (CmmCondBranch (cond2 tag) no_cons)
226                    -- Yes, jump to switch statement
227                    ; stmtC (CmmJump (CmmLit (CmmLabel lbl)))
228                    ; labelC no_cons
229                    -- No, enter the closure.
230                    ; enterClosure
231                    }
232 -}
233               -- No case expression involved, enter the closure.
234               | otherwise
235               = do { stmtC $ untag_node dflags
236                    ; enterClosure
237                    }
238         where
239           --cond1 tag  = cmmULtWord tag lowCons
240           -- More efficient than the above?
241 {-
242           tag_expr   = cmmGetClosureType (CmmReg nodeReg)
243           cond1 tag  = cmmEqWord tag (CmmLit (mkIntCLit 0))
244           cond2 tag  = cmmUGtWord tag highCons
245           lowCons    = CmmLit (mkIntCLit 1)
246             -- CONSTR
247           highCons   = CmmLit (mkIntCLit 8)
248             -- CONSTR_NOCAF_STATIC (from ClosureType.h)
249 -}
250
251 directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)]
252            -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts
253            -> Code
254 directCall sp lbl args extra_args live_node assts = do
255   dflags <- getDynFlags
256   let
257         -- First chunk of args go in registers
258         (reg_arg_amodes, stk_args) = assignCallRegs dflags args
259      
260         -- Any "extra" arguments are placed in frames on the
261         -- stack after the other arguments.
262         slow_stk_args = slowArgs dflags extra_args
263
264         reg_assts = assignToRegs reg_arg_amodes
265         live_args = map snd reg_arg_amodes
266         live_regs = Just $ (fromMaybe [] live_node) ++ live_args
267   --
268   (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args)
269   emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts
270   doFinalJump final_sp False $ jumpToLbl lbl live_regs
271
272 -- -----------------------------------------------------------------------------
273 -- The final clean-up before we do a jump at the end of a basic block.
274 -- This code is shared by tail-calls and returns.
275
276 doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code 
277 doFinalJump final_sp is_let_no_escape jump_code
278   = do  { -- Adjust the high-water mark if necessary
279           adjustStackHW final_sp
280
281         -- Push a return address if necessary (after the assignments
282         -- above, in case we clobber a live stack location)
283         --
284         -- DONT push the return address when we're about to jump to a
285         -- let-no-escape: the final tail call in the let-no-escape
286         -- will do this.
287         ; eob <- getEndOfBlockInfo
288         ; whenC (not is_let_no_escape) (pushReturnAddress eob)
289
290             -- Final adjustment of Sp/Hp
291         ; adjustSpAndHp final_sp
292
293             -- and do the jump
294         ; jump_code }
295
296 -- ----------------------------------------------------------------------------
297 -- A general return (just a special case of doFinalJump, above)
298
299 performReturn :: Code   -- The code to execute to actually do the return
300               -> Code
301
302 performReturn finish_code
303   = do  { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo
304         ; doFinalJump args_sp False finish_code }
305
306 -- ----------------------------------------------------------------------------
307 -- Primitive Returns
308 -- Just load the return value into the right register, and return.
309
310 performPrimReturn :: CgRep -> CmmExpr -> Code
311
312 -- non-void return value
313 performPrimReturn rep amode | not (isVoidArg rep)
314   = do { stmtC (CmmAssign ret_reg amode)
315        ; performReturn $ emitReturnInstr live_regs }
316   where
317     -- careful here as 'dataReturnConvPrim' will panic if given a Void rep
318     ret_reg@(CmmGlobal r) = dataReturnConvPrim rep
319     live_regs = Just [r]
320
321 -- void return value
322 performPrimReturn _ _
323   = performReturn $ emitReturnInstr (Just [])
324
325
326 -- ---------------------------------------------------------------------------
327 -- Unboxed tuple returns
328
329 -- These are a bit like a normal tail call, except that:
330 --
331 --   - The tail-call target is an info table on the stack
332 --
333 --   - We separate stack arguments into pointers and non-pointers,
334 --     to make it easier to leave things in a sane state for a heap check.
335 --     This is OK because we can never partially-apply an unboxed tuple,
336 --     unlike a function.  The same technique is used when calling
337 --     let-no-escape functions, because they also can't be partially
338 --     applied.
339
340 returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
341 returnUnboxedTuple amodes
342   = do  { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo
343         ; tickyUnboxedTupleReturn (length amodes)
344         ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes
345         ; emitSimultaneously assts
346         ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) }
347
348 pushUnboxedTuple :: VirtualSpOffset             -- Sp at which to start pushing
349                  -> [(CgRep, CmmExpr)]          -- amodes of the components
350                  -> FCode (VirtualSpOffset,     -- final Sp
351                            CmmStmts,            -- assignments (regs+stack)
352                            [GlobalReg])         -- registers used (liveness)
353
354 pushUnboxedTuple sp [] 
355   = return (sp, noStmts, [])
356 pushUnboxedTuple sp amodes
357   = do  { dflags <- getDynFlags
358         ; let   (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes
359                 live_regs = map snd reg_arg_amodes
360         
361                 -- separate the rest of the args into pointers and non-pointers
362                 (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes
363                 reg_arg_assts = assignToRegs reg_arg_amodes
364                 
365             -- push ptrs, then nonptrs, on the stack
366         ; (ptr_sp,   ptr_assts)  <- mkStkAmodes sp ptr_args
367         ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args
368
369         ; returnFC (final_sp,
370                     reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts,
371                     live_regs) }
372     
373                   
374 -- -----------------------------------------------------------------------------
375 -- Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
376 -- we want to do things in a slightly different order to normal:
377 -- 
378 --              - push return address
379 --              - adjust stack pointer
380 --              - r = call(args...)
381 --              - assign regs for unboxed tuple (usually just R1 = r)
382 --              - return to continuation
383 -- 
384 -- The return address (i.e. stack frame) must be on the stack before
385 -- doing the call in case the call ends up in the garbage collector.
386 -- 
387 -- Sadly, the information about the continuation is lost after we push it
388 -- (in order to avoid pushing it again), so we end up doing a needless
389 -- indirect jump (ToDo).
390
391 ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code
392 ccallReturnUnboxedTuple amodes before_jump
393   = do  { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo
394
395         -- Push a return address if necessary
396         ; pushReturnAddress eob
397         ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack)
398             (do { adjustSpAndHp args_sp
399                 ; before_jump
400                 ; returnUnboxedTuple amodes })
401     }
402
403 -- -----------------------------------------------------------------------------
404 -- Calling an out-of-line primop
405
406 tailCallPrimOp :: PrimOp -> [StgArg] -> Code
407 tailCallPrimOp op
408  = tailCallPrim (mkRtsPrimOpLabel op)
409
410 tailCallPrimCall :: PrimCall -> [StgArg] -> Code
411 tailCallPrimCall primcall
412  = tailCallPrim (mkPrimCallLabel primcall)
413
414 tailCallPrim :: CLabel -> [StgArg] -> Code
415 tailCallPrim lbl args
416  = do { dflags <- getDynFlags
417         -- We're going to perform a normal-looking tail call, 
418                 -- except that *all* the arguments will be in registers.
419                 -- Hence the ASSERT( null leftovers )
420         ; arg_amodes <- getArgAmodes args
421         ; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes
422               live_regs = Just $ map snd arg_regs
423               jump_to_primop = jumpToLbl lbl live_regs
424
425         ; ASSERT(null leftovers) -- no stack-resident args
426           emitSimultaneously (assignToRegs arg_regs)
427
428         ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
429         ; doFinalJump args_sp False jump_to_primop }
430
431 -- -----------------------------------------------------------------------------
432 -- Return Addresses
433
434 -- We always push the return address just before performing a tail call
435 -- or return.  The reason we leave it until then is because the stack
436 -- slot that the return address is to go into might contain something
437 -- useful.
438 -- 
439 -- If the end of block info is 'CaseAlts', then we're in the scrutinee of a
440 -- case expression and the return address is still to be pushed.
441 -- 
442 -- There are cases where it doesn't look necessary to push the return
443 -- address: for example, just before doing a return to a known
444 -- continuation.  However, the continuation will expect to find the
445 -- return address on the stack in case it needs to do a heap check.
446
447 pushReturnAddress :: EndOfBlockInfo -> Code
448
449 pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _))
450   = do  { sp_rel <- getSpRelOffset args_sp
451         ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
452
453 pushReturnAddress _ = nopC
454
455 -- -----------------------------------------------------------------------------
456 -- Misc.
457
458 -- Passes no argument to the destination procedure
459 jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code
460 jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live
461
462 assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts
463 assignToRegs reg_args 
464   = mkStmts [ CmmAssign (CmmGlobal reg_id) expr
465             | (expr, reg_id) <- reg_args ] 
466 \end{code}
467
468
469 %************************************************************************
470 %*                                                                      *
471 \subsection[CgStackery-adjust]{Adjusting the stack pointers}
472 %*                                                                      *
473 %************************************************************************
474
475 This function adjusts the stack and heap pointers just before a tail
476 call or return.  The stack pointer is adjusted to its final position
477 (i.e. to point to the last argument for a tail call, or the activation
478 record for a return).  The heap pointer may be moved backwards, in
479 cases where we overallocated at the beginning of the basic block (see
480 CgCase.lhs for discussion).
481
482 These functions {\em do not} deal with high-water-mark adjustment.
483 That's done by functions which allocate stack space.
484
485 \begin{code}
486 adjustSpAndHp :: VirtualSpOffset        -- New offset for Arg stack ptr
487               -> Code
488 adjustSpAndHp newRealSp 
489   = do  { -- Adjust stack, if necessary.
490           -- NB: the conditional on the monad-carried realSp
491           --     is out of line (via codeOnly), to avoid a black hole
492         ; new_sp <- getSpRelOffset newRealSp
493         ; checkedAbsC (CmmAssign spReg new_sp)  -- Will generate no code in the case
494         ; setRealSp newRealSp                   -- where realSp==newRealSp
495
496           -- Adjust heap.  The virtual heap pointer may be less than the real Hp
497           -- because the latter was advanced to deal with the worst-case branch
498           -- of the code, and we may be in a better-case branch.  In that case,
499           -- move the real Hp *back* and retract some ticky allocation count.
500         ; hp_usg <- getHpUsage
501         ; let rHp = realHp hp_usg
502               vHp = virtHp hp_usg
503         ; new_hp <- getHpRelOffset vHp
504         ; checkedAbsC (CmmAssign hpReg new_hp)  -- Generates nothing when vHp==rHp
505         ; tickyAllocHeap (vHp - rHp)            -- ...ditto
506         ; setRealHp vHp
507         }
508 \end{code}
509