Check category of type instances and some newtype family fixes

[ghc-hetmet.git] / compiler / codeGen / CgTailCall.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgTailCall.lhs,v 1.43 2005/06/21 10:44:41 simonmar Exp $
%
%********************************************************
%*                                                      *
\section[CgTailCall]{Tail calls: converting @StgApps@}
%*                                                      *
%********************************************************

\begin{code}
module CgTailCall (
        cgTailCall, performTailCall,
        performReturn, performPrimReturn,
        emitKnownConReturnCode, emitAlgReturnCode,
        returnUnboxedTuple, ccallReturnUnboxedTuple,
        pushUnboxedTuple,
        tailCallPrimOp,

        pushReturnAddress
    ) where

#include "HsVersions.h"

import CgMonad
import CgBindery        ( getArgAmodes, getCgIdInfo, CgIdInfo, maybeLetNoEscape,
                          idInfoToAmode, cgIdInfoId, cgIdInfoLF,
                          cgIdInfoArgRep )
import CgInfoTbls       ( entryCode, emitDirectReturnInstr, dataConTagZ,
                          emitVectoredReturnInstr, closureInfoPtr )
import CgCallConv
import CgStackery       ( setRealSp, mkStkAmodes, adjustStackHW,
                          getSpRelOffset )
import CgHeapery        ( setRealHp, getHpRelOffset )
import CgUtils          ( emitSimultaneously )
import CgTicky
import ClosureInfo
import SMRep            ( CgRep, isVoidArg, separateByPtrFollowness )
import Cmm      
import CmmUtils
import CLabel           ( CLabel, mkRtsPrimOpLabel, mkSeqInfoLabel )
import Type             ( isUnLiftedType )
import Id               ( Id, idName, idUnique, idType )
import DataCon          ( DataCon, dataConTyCon )
import StgSyn           ( StgArg )
import TyCon            ( TyCon )
import PrimOp           ( PrimOp )
import Outputable

import Monad            ( when )

-----------------------------------------------------------------------------
-- Tail Calls

cgTailCall :: Id -> [StgArg] -> Code

-- Here's the code we generate for a tail call.  (NB there may be no
-- arguments, in which case this boils down to just entering a variable.)
-- 
--    * Put args in the top locations of the stack.
--    * Adjust the stack ptr
--    * Make R1 point to the function closure if necessary.
--    * Perform the call.
--
-- Things to be careful about:
--
--    * Don't overwrite stack locations before you have finished with
--      them (remember you need the function and the as-yet-unmoved
--      arguments).
--    * Preferably, generate no code to replace x by x on the stack (a
--      common situation in tail-recursion).
--    * Adjust the stack high water mark appropriately.
-- 
-- Treat unboxed locals exactly like literals (above) except use the addr
-- mode for the local instead of (CLit lit) in the assignment.

cgTailCall fun args
  = do  { fun_info <- getCgIdInfo fun

        ; if isUnLiftedType (idType fun)
          then  -- Primitive return
                ASSERT( null args )
            do  { fun_amode <- idInfoToAmode fun_info
                ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } 

          else -- Normal case, fun is boxed
            do  { arg_amodes <- getArgAmodes args
                ; performTailCall fun_info arg_amodes noStmts }
        }
                

-- -----------------------------------------------------------------------------
-- The guts of a tail-call

performTailCall 
        :: CgIdInfo             -- The function
        -> [(CgRep,CmmExpr)]    -- Args
        -> CmmStmts             -- Pending simultaneous assignments
                                --  *** GUARANTEED to contain only stack assignments.
        -> Code

performTailCall fun_info arg_amodes pending_assts
  | Just join_sp <- maybeLetNoEscape fun_info
  =        -- A let-no-escape is slightly different, because we
           -- arrange the stack arguments into pointers and non-pointers
           -- to make the heap check easier.  The tail-call sequence
           -- is very similar to returning an unboxed tuple, so we
           -- share some code.
     do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes
        ; emitSimultaneously (pending_assts `plusStmts` arg_assts)
        ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info))
        ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) }

  | otherwise
  = do  { fun_amode <- idInfoToAmode fun_info
        ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode)
              opt_node_asst | nodeMustPointToIt lf_info = node_asst
                            | otherwise                 = noStmts
        ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
        ; this_pkg <- getThisPackage

        ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of

            -- Node must always point to things we enter
            EnterIt -> do
                { emitSimultaneously (node_asst `plusStmts` pending_assts) 
                ; let target = entryCode (closureInfoPtr (CmmReg nodeReg))
                ; doFinalJump sp False (stmtC (CmmJump target [])) }
    
            -- A function, but we have zero arguments.  It is already in WHNF,
            -- so we can just return it.  
            -- As with any return, Node must point to it.
            ReturnIt -> do
                { emitSimultaneously (node_asst `plusStmts` pending_assts)
                ; doFinalJump sp False emitDirectReturnInstr }
    
            -- A real constructor.  Don't bother entering it, 
            -- just do the right sort of return instead.
            -- As with any return, Node must point to it.
            ReturnCon con -> do
                { emitSimultaneously (node_asst `plusStmts` pending_assts)
                ; doFinalJump sp False (emitKnownConReturnCode con) }

            JumpToIt lbl -> do
                { emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
                ; doFinalJump sp False (jumpToLbl lbl) }
    
            -- A slow function call via the RTS apply routines
            -- Node must definitely point to the thing
            SlowCall -> do 
                {  when (not (null arg_amodes)) $ do
                   { if (isKnownFun lf_info) 
                        then tickyKnownCallTooFewArgs
                        else tickyUnknownCall
                   ; tickySlowCallPat (map fst arg_amodes) 
                   }

                ; let (apply_lbl, args, extra_args) 
                        = constructSlowCall arg_amodes

                ; directCall sp apply_lbl args extra_args 
                        (node_asst `plusStmts` pending_assts)
                }
    
            -- A direct function call (possibly with some left-over arguments)
            DirectEntry lbl arity -> do
                { if arity == length arg_amodes
                        then tickyKnownCallExact
                        else do tickyKnownCallExtraArgs
                                tickySlowCallPat (map fst (drop arity arg_amodes))

                ; let
                     -- The args beyond the arity go straight on the stack
                     (arity_args, extra_args) = splitAt arity arg_amodes
     
                ; directCall sp lbl arity_args extra_args
                        (opt_node_asst `plusStmts` pending_assts)
                }
        }
  where
    fun_name  = idName (cgIdInfoId fun_info)
    lf_info   = cgIdInfoLF fun_info



directCall sp lbl args extra_args assts = do
  let
        -- First chunk of args go in registers
        (reg_arg_amodes, stk_args) = assignCallRegs args
     
        -- Any "extra" arguments are placed in frames on the
        -- stack after the other arguments.
        slow_stk_args = slowArgs extra_args

        reg_assts = assignToRegs reg_arg_amodes
  --
  (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args)

  emitSimultaneously (reg_assts     `plusStmts`
                      stk_assts     `plusStmts`
                      assts)

  doFinalJump final_sp False (jumpToLbl lbl)

-- -----------------------------------------------------------------------------
-- The final clean-up before we do a jump at the end of a basic block.
-- This code is shared by tail-calls and returns.

doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code 
doFinalJump final_sp is_let_no_escape jump_code
  = do  { -- Adjust the high-water mark if necessary
          adjustStackHW final_sp

        -- Push a return address if necessary (after the assignments
        -- above, in case we clobber a live stack location)
        --
        -- DONT push the return address when we're about to jump to a
        -- let-no-escape: the final tail call in the let-no-escape
        -- will do this.
        ; eob <- getEndOfBlockInfo
        ; whenC (not is_let_no_escape) (pushReturnAddress eob)

            -- Final adjustment of Sp/Hp
        ; adjustSpAndHp final_sp

            -- and do the jump
        ; jump_code }

-- -----------------------------------------------------------------------------
-- A general return (just a special case of doFinalJump, above)

performReturn :: Code           -- The code to execute to actually do the return
              -> Code

performReturn finish_code
  = do  { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo
        ; doFinalJump args_sp False{-not a LNE-} finish_code }

-- -----------------------------------------------------------------------------
-- Primitive Returns
-- Just load the return value into the right register, and return.

performPrimReturn :: CgRep -> CmmExpr   -- The thing to return
                  -> Code
performPrimReturn rep amode
  =  do { whenC (not (isVoidArg rep))
                (stmtC (CmmAssign ret_reg amode))
        ; performReturn emitDirectReturnInstr }
  where
    ret_reg = dataReturnConvPrim rep

-- -----------------------------------------------------------------------------
-- Algebraic constructor returns

-- Constructor is built on the heap; Node is set.
-- All that remains is to do the right sort of jump.

emitKnownConReturnCode :: DataCon -> Code
emitKnownConReturnCode con
  = emitAlgReturnCode (dataConTyCon con)
                      (CmmLit (mkIntCLit (dataConTagZ con)))
                        -- emitAlgReturnCode requires zero-indexed tag

emitAlgReturnCode :: TyCon -> CmmExpr -> Code
-- emitAlgReturnCode is used both by emitKnownConReturnCode,
-- and by by PrimOps that return enumerated types (i.e.
-- all the comparison operators).
emitAlgReturnCode tycon tag
 =  do  { case ctrlReturnConvAlg tycon of
            VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz
                                        ; emitVectoredReturnInstr tag }
            UnvectoredReturn _    -> emitDirectReturnInstr 
        }


-- ---------------------------------------------------------------------------
-- Unboxed tuple returns

-- These are a bit like a normal tail call, except that:
--
--   - The tail-call target is an info table on the stack
--
--   - We separate stack arguments into pointers and non-pointers,
--     to make it easier to leave things in a sane state for a heap check.
--     This is OK because we can never partially-apply an unboxed tuple,
--     unlike a function.  The same technique is used when calling
--     let-no-escape functions, because they also can't be partially
--     applied.

returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
returnUnboxedTuple amodes
  = do  { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo
        ; tickyUnboxedTupleReturn (length amodes)
        ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
        ; emitSimultaneously assts
        ; doFinalJump final_sp False{-not a LNE-} emitDirectReturnInstr }

pushUnboxedTuple :: VirtualSpOffset             -- Sp at which to start pushing
                 -> [(CgRep, CmmExpr)]          -- amodes of the components
                 -> FCode (VirtualSpOffset,     -- final Sp
                           CmmStmts)            -- assignments (regs+stack)

pushUnboxedTuple sp [] 
  = return (sp, noStmts)
pushUnboxedTuple sp amodes
  = do  { let   (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes
        
                -- separate the rest of the args into pointers and non-pointers
                (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes
                reg_arg_assts = assignToRegs reg_arg_amodes
                
            -- push ptrs, then nonptrs, on the stack
        ; (ptr_sp,   ptr_assts)  <- mkStkAmodes sp ptr_args
        ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args

        ; returnFC (final_sp,
                    reg_arg_assts `plusStmts` 
                    ptr_assts `plusStmts` nptr_assts) }
    
                  
-- -----------------------------------------------------------------------------
-- Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
-- we want to do things in a slightly different order to normal:
-- 
--              - push return address
--              - adjust stack pointer
--              - r = call(args...)
--              - assign regs for unboxed tuple (usually just R1 = r)
--              - return to continuation
-- 
-- The return address (i.e. stack frame) must be on the stack before
-- doing the call in case the call ends up in the garbage collector.
-- 
-- Sadly, the information about the continuation is lost after we push it
-- (in order to avoid pushing it again), so we end up doing a needless
-- indirect jump (ToDo).

ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code
ccallReturnUnboxedTuple amodes before_jump
  = do  { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo

        -- Push a return address if necessary
        ; pushReturnAddress eob
        ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack)
            (do { adjustSpAndHp args_sp
                ; before_jump
                ; returnUnboxedTuple amodes })
    }

-- -----------------------------------------------------------------------------
-- Calling an out-of-line primop

tailCallPrimOp :: PrimOp -> [StgArg] -> Code
tailCallPrimOp op args
 = do   {       -- We're going to perform a normal-looking tail call, 
                -- except that *all* the arguments will be in registers.
                -- Hence the ASSERT( null leftovers )
          arg_amodes <- getArgAmodes args
        ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes
              jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op)

        ; ASSERT(null leftovers) -- no stack-resident args
          emitSimultaneously (assignToRegs arg_regs)

        ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
        ; doFinalJump args_sp False{-not a LNE-} jump_to_primop }

-- -----------------------------------------------------------------------------
-- Return Addresses

-- We always push the return address just before performing a tail call
-- or return.  The reason we leave it until then is because the stack
-- slot that the return address is to go into might contain something
-- useful.
-- 
-- If the end of block info is 'CaseAlts', then we're in the scrutinee of a
-- case expression and the return address is still to be pushed.
-- 
-- There are cases where it doesn't look necessary to push the return
-- address: for example, just before doing a return to a known
-- continuation.  However, the continuation will expect to find the
-- return address on the stack in case it needs to do a heap check.

pushReturnAddress :: EndOfBlockInfo -> Code

pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False))
  = do  { sp_rel <- getSpRelOffset args_sp
        ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }

-- For a polymorphic case, we have two return addresses to push: the case
-- return, and stg_seq_frame_info which turns a possible vectored return
-- into a direct one.
pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ True))
  = do  { sp_rel <- getSpRelOffset (args_sp-1)
        ; stmtC (CmmStore sp_rel (mkLblExpr lbl))
        ; sp_rel <- getSpRelOffset args_sp
        ; stmtC (CmmStore sp_rel (CmmLit (CmmLabel mkSeqInfoLabel))) }

pushReturnAddress _ = nopC

-- -----------------------------------------------------------------------------
-- Misc.

jumpToLbl :: CLabel -> Code
-- Passes no argument to the destination procedure
jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [{- No args -}])

assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts
assignToRegs reg_args 
  = mkStmts [ CmmAssign (CmmGlobal reg_id) expr
            | (expr, reg_id) <- reg_args ] 
\end{code}


%************************************************************************
%*                                                                      *
\subsection[CgStackery-adjust]{Adjusting the stack pointers}
%*                                                                      *
%************************************************************************

This function adjusts the stack and heap pointers just before a tail
call or return.  The stack pointer is adjusted to its final position
(i.e. to point to the last argument for a tail call, or the activation
record for a return).  The heap pointer may be moved backwards, in
cases where we overallocated at the beginning of the basic block (see
CgCase.lhs for discussion).

These functions {\em do not} deal with high-water-mark adjustment.
That's done by functions which allocate stack space.

\begin{code}
adjustSpAndHp :: VirtualSpOffset        -- New offset for Arg stack ptr
              -> Code
adjustSpAndHp newRealSp 
  = do  { -- Adjust stack, if necessary.
          -- NB: the conditional on the monad-carried realSp
          --     is out of line (via codeOnly), to avoid a black hole
        ; new_sp <- getSpRelOffset newRealSp
        ; checkedAbsC (CmmAssign spReg new_sp)  -- Will generate no code in the case
        ; setRealSp newRealSp                   -- where realSp==newRealSp

          -- Adjust heap.  The virtual heap pointer may be less than the real Hp
          -- because the latter was advanced to deal with the worst-case branch
          -- of the code, and we may be in a better-case branch.  In that case,
          -- move the real Hp *back* and retract some ticky allocation count.
        ; hp_usg <- getHpUsage
        ; let rHp = realHp hp_usg
              vHp = virtHp hp_usg
        ; new_hp <- getHpRelOffset vHp
        ; checkedAbsC (CmmAssign hpReg new_hp)  -- Generates nothing when vHp==rHp
        ; tickyAllocHeap (vHp - rHp)            -- ...ditto
        ; setRealHp vHp
        }
\end{code}