-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
--
-- CgCallConv
--
-- The datatypes and functions here encapsulate the 
-- calling and return conventions used by the code generator.
--
-----------------------------------------------------------------------------

{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

module CgCallConv (
	-- Argument descriptors
	mkArgDescr, 

	-- Liveness
	mkRegLiveness, 

	-- Register assignment
	assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,

	-- Calls
	constructSlowCall, slowArgs, slowCallPattern,

	-- Returns
	dataReturnConvPrim,
	getSequelAmode
    ) where

import CgMonad
import CgProf
import SMRep

import OldCmm
import CLabel

import Constants
import CgStackery
import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
import OldCmmUtils
import Maybes
import Id
import Name
import Util
import StaticFlags
import Module
import FastString
import Outputable
import Data.Bits

-------------------------------------------------------------------------
--
--	Making argument descriptors
--
--  An argument descriptor describes the layout of args on the stack,
--  both for 	* GC (stack-layout) purposes, and 
--		* saving/restoring registers when a heap-check fails
--
-- Void arguments aren't important, therefore (contrast constructSlowCall)
--
-------------------------------------------------------------------------

-- bring in ARG_P, ARG_N, etc.
#include "../includes/rts/storage/FunTypes.h"

-------------------------
mkArgDescr :: Name -> [Id] -> FCode ArgDescr
mkArgDescr _nm args 
  = case stdPattern arg_reps of
	Just spec_id -> return (ArgSpec spec_id)
	Nothing      -> return (ArgGen arg_bits)
  where
    arg_bits = argBits arg_reps
    arg_reps = filter nonVoidArg (map idCgRep args)
	-- Getting rid of voids eases matching of standard patterns

argBits :: [CgRep] -> [Bool]	-- True for non-ptr, False for ptr
argBits [] 		= []
argBits (PtrArg : args) = False : argBits args
argBits (arg    : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args

stdPattern :: [CgRep] -> Maybe StgHalfWord
stdPattern []          = Just ARG_NONE	-- just void args, probably

stdPattern [PtrArg]    = Just ARG_P
stdPattern [FloatArg]  = Just ARG_F
stdPattern [DoubleArg] = Just ARG_D
stdPattern [LongArg]   = Just ARG_L
stdPattern [NonPtrArg] = Just ARG_N
	 
stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
stdPattern [NonPtrArg,PtrArg]    = Just ARG_NP
stdPattern [PtrArg,NonPtrArg]    = Just ARG_PN
stdPattern [PtrArg,PtrArg]       = Just ARG_PP

stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
stdPattern [NonPtrArg,NonPtrArg,PtrArg]    = Just ARG_NNP
stdPattern [NonPtrArg,PtrArg,NonPtrArg]    = Just ARG_NPN
stdPattern [NonPtrArg,PtrArg,PtrArg]	   = Just ARG_NPP
stdPattern [PtrArg,NonPtrArg,NonPtrArg]    = Just ARG_PNN
stdPattern [PtrArg,NonPtrArg,PtrArg]	   = Just ARG_PNP
stdPattern [PtrArg,PtrArg,NonPtrArg]	   = Just ARG_PPN
stdPattern [PtrArg,PtrArg,PtrArg]	   = Just ARG_PPP
	 
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg]	       = Just ARG_PPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg]        = Just ARG_PPPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
stdPattern _ = Nothing


-------------------------------------------------------------------------
--
--		Bitmap describing register liveness
--		across GC when doing a "generic" heap check
--		(a RET_DYN stack frame).
--
-- NB. Must agree with these macros (currently in StgMacros.h): 
-- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
-------------------------------------------------------------------------

mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
mkRegLiveness regs ptrs nptrs
  = (fromIntegral nptrs `shiftL` 16) .|. 
    (fromIntegral ptrs  `shiftL` 24) .|.
    all_non_ptrs `xor` reg_bits regs
  where
    all_non_ptrs = 0xff

    reg_bits [] = 0
    reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
  	= (1 `shiftL` (i - 1)) .|. reg_bits regs
    reg_bits (_ : regs)
	= reg_bits regs
  
-------------------------------------------------------------------------
--
--		Pushing the arguments for a slow call
--
-------------------------------------------------------------------------

-- For a slow call, we must take a bunch of arguments and intersperse
-- some stg_ap_<pattern>_ret_info return addresses.
constructSlowCall
	:: [(CgRep,CmmExpr)]
	-> (CLabel,		-- RTS entry point for call
	   [(CgRep,CmmExpr)],	-- args to pass to the entry point
	   [(CgRep,CmmExpr)])	-- stuff to save on the stack

   -- don't forget the zero case
constructSlowCall [] 
  = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])

constructSlowCall amodes
  = (stg_ap_pat, these, rest)
  where 
    stg_ap_pat = mkRtsApFastLabel arg_pat
    (arg_pat, these, rest) = matchSlowPattern amodes

-- | 'slowArgs' takes a list of function arguments and prepares them for
-- pushing on the stack for "extra" arguments to a function which requires
-- fewer arguments than we currently have.
slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
slowArgs [] = []
slowArgs amodes
  | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest
  | otherwise          =              this_pat ++ slowArgs rest
  where
    (arg_pat, args, rest) = matchSlowPattern amodes
    stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
    this_pat   = (NonPtrArg, mkLblExpr stg_ap_pat) : args
    save_cccs  = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)]
    save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")

matchSlowPattern :: [(CgRep,CmmExpr)] 
		 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
matchSlowPattern amodes = (arg_pat, these, rest)
  where (arg_pat, n)  = slowCallPattern (map fst amodes)
	(these, rest) = splitAt n amodes

-- These cases were found to cover about 99% of all slow calls:
slowCallPattern :: [CgRep] -> (FastString, Int)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) 	    = (fsLit "stg_ap_ppppp", 5)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (fsLit "stg_ap_pppp", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) 	= (fsLit "stg_ap_pppv", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: _)       	= (fsLit "stg_ap_ppp", 3)
slowCallPattern (PtrArg: PtrArg: VoidArg: _)       	= (fsLit "stg_ap_ppv", 3)
slowCallPattern (PtrArg: PtrArg: _)			= (fsLit "stg_ap_pp", 2)
slowCallPattern (PtrArg: VoidArg: _)			= (fsLit "stg_ap_pv", 2)
slowCallPattern (PtrArg: _)				= (fsLit "stg_ap_p", 1)
slowCallPattern (VoidArg: _)				= (fsLit "stg_ap_v", 1)
slowCallPattern (NonPtrArg: _)				= (fsLit "stg_ap_n", 1)
slowCallPattern (FloatArg: _)				= (fsLit "stg_ap_f", 1)
slowCallPattern (DoubleArg: _)				= (fsLit "stg_ap_d", 1)
slowCallPattern (LongArg: _)				= (fsLit "stg_ap_l", 1)
slowCallPattern _ 					= panic "CgStackery.slowCallPattern"

-------------------------------------------------------------------------
--
--		Return conventions
--
-------------------------------------------------------------------------

dataReturnConvPrim :: CgRep -> CmmReg
dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1 VGcPtr)
dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"


-- getSequelAmode returns an amode which refers to an info table.  The info
-- table will always be of the RET_(BIG|SMALL) kind.  We're careful
-- not to handle real code pointers, just in case we're compiling for 
-- an unregisterised/untailcallish architecture, where info pointers and
-- code pointers aren't the same.
-- DIRE WARNING.
-- The OnStack case of sequelToAmode delivers an Amode which is only
-- valid just before the final control transfer, because it assumes
-- that Sp is pointing to the top word of the return address.  This
-- seems unclean but there you go.

getSequelAmode :: FCode CmmExpr
getSequelAmode
  = do	{ EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
	; case sequel of
	    OnStack -> do { sp_rel <- getSpRelOffset virt_sp
			  ; returnFC (CmmLoad sp_rel bWord) }

	    CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
	}

-------------------------------------------------------------------------
--
--		Register assignment
--
-------------------------------------------------------------------------

--  How to assign registers for 
--
--	1) Calling a fast entry point.
--	2) Returning an unboxed tuple.
--	3) Invoking an out-of-line PrimOp.
--
-- Registers are assigned in order.
-- 
-- If we run out, we don't attempt to assign any further registers (even
-- though we might have run out of only one kind of register); we just
-- return immediately with the left-overs specified.
-- 
-- The alternative version @assignAllRegs@ uses the complete set of
-- registers, including those that aren't mapped to real machine
-- registers.  This is used for calling special RTS functions and PrimOps
-- which expect their arguments to always be in the same registers.

assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
	:: [(CgRep,a)]		-- Arg or result values to assign
	-> ([(a, GlobalReg)],	-- Register assignment in same order
				-- for *initial segment of* input list
				--   (but reversed; doesn't matter)
				-- VoidRep args do not appear here
	    [(CgRep,a)])	-- Leftover arg or result values

assignCallRegs args
  = assign_regs args (mkRegTbl [node])
	-- The entry convention for a function closure
	-- never uses Node for argument passing; instead
	-- Node points to the function closure itself

assignPrimOpCallRegs args
 = assign_regs args (mkRegTbl_allRegs [])
	-- For primops, *all* arguments must be passed in registers

assignReturnRegs args
 -- when we have a single non-void component to return, use the normal
 -- unpointed return convention.  This make various things simpler: it
 -- means we can assume a consistent convention for IO, which is useful
 -- when writing code that relies on knowing the IO return convention in 
 -- the RTS (primops, especially exception-related primops).
 -- Also, the bytecode compiler assumes this when compiling
 -- case expressions and ccalls, so it only needs to know one set of
 -- return conventions.
 | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
    = ([(arg, r)], [])
 | otherwise
    = assign_regs args (mkRegTbl [])
	-- For returning unboxed tuples etc, 
	-- we use all regs
 where 
       non_void_args = filter ((/= VoidArg).fst) args

assign_regs :: [(CgRep,a)]     	-- Arg or result values to assign
	    -> AvailRegs	-- Regs still avail: Vanilla, Float, Double, Longs
	    -> ([(a, GlobalReg)], [(CgRep, a)])
assign_regs args supply
  = go args [] supply
  where
    go [] acc _ = (acc, [])	-- Return the results reversed (doesn't matter)
    go ((VoidArg,_) : args) acc supply 	-- Skip void arguments; they aren't passed, and
	= go args acc supply		-- there's nothing to bind them to
    go ((rep,arg) : args) acc supply 
	= case assign_reg rep supply of
		Just (reg, supply') -> go args ((arg,reg):acc) supply'
		Nothing	   	    -> (acc, (rep,arg):args) 	-- No more regs

assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
    -- PtrArg and NonPtrArg both go in a vanilla register
assign_reg _         _                  = Nothing


-------------------------------------------------------------------------
--
--		Register supplies
--
-------------------------------------------------------------------------

-- Vanilla registers can contain pointers, Ints, Chars.
-- Floats and doubles have separate register supplies.
--
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.

useVanillaRegs :: Int
useVanillaRegs | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Vanilla_REG
useFloatRegs :: Int
useFloatRegs   | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Float_REG
useDoubleRegs :: Int
useDoubleRegs  | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Double_REG
useLongRegs :: Int
useLongRegs    | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Long_REG

vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos	 = regList useVanillaRegs
floatRegNos	 = regList useFloatRegs
doubleRegNos	 = regList useDoubleRegs
longRegNos       = regList useLongRegs

allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
allFloatRegNos	 = regList mAX_Float_REG
allDoubleRegNos	 = regList mAX_Double_REG
allLongRegNos	 = regList mAX_Long_REG

regList :: Int -> [Int]
regList n = [1 .. n]

type AvailRegs = ( [Int]   -- available vanilla regs.
		 , [Int]   -- floats
		 , [Int]   -- doubles
		 , [Int]   -- longs (int64 and word64)
		 )

mkRegTbl :: [GlobalReg] -> AvailRegs
mkRegTbl regs_in_use
  = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos

mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
mkRegTbl_allRegs regs_in_use
  = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos

mkRegTbl' :: [GlobalReg] -> [Int] -> [Int] -> [Int] -> [Int]
          -> ([Int], [Int], [Int], [Int])
mkRegTbl' regs_in_use vanillas floats doubles longs
  = (ok_vanilla, ok_float, ok_double, ok_long)
  where
    ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas
		    -- ptrhood isn't looked at, hence we can use any old rep.
    ok_float   = mapCatMaybes (select FloatReg)	  floats
    ok_double  = mapCatMaybes (select DoubleReg)  doubles
    ok_long    = mapCatMaybes (select LongReg)    longs   

    select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
	-- one we've unboxed the Int, we make a GlobalReg
	-- and see if it is already in use; if not, return its number.

    select mk_reg_fun cand
      = let
	    reg = mk_reg_fun cand
	in
	if reg `not_elem` regs_in_use
	then Just cand
	else Nothing
      where
	not_elem = isn'tIn "mkRegTbl"