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