module CgCallConv (
mkArgDescr, argDescrType,
isBigLiveness, mkRegLiveness,
smallLiveness, mkLivenessCLit,
assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
constructSlowCall, slowArgs, slowCallPattern,
dataReturnConvPrim,
getSequelAmode
) where
import CgUtils
import CgMonad
import SMRep
import Cmm
import CLabel
import Constants
import ClosureInfo
import CgStackery
import CmmUtils
import Maybes
import Id
import Name
import Bitmap
import Util
import StaticFlags
import Module
import FastString
import Outputable
import Unique
import Data.Bits
#include "../includes/rts/storage/FunTypes.h"
argDescrType :: ArgDescr -> StgHalfWord
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
| isBigLiveness liveness = ARG_GEN_BIG
| otherwise = ARG_GEN
mkArgDescr :: Name -> [Id] -> FCode ArgDescr
mkArgDescr nm args
= case stdPattern arg_reps of
Just spec_id -> return (ArgSpec spec_id)
Nothing -> do { liveness <- mkLiveness nm size bitmap
; return (ArgGen liveness) }
where
arg_reps = filter nonVoidArg (map idCgRep args)
bitmap = mkBitmap arg_bits
arg_bits = argBits arg_reps
size = length arg_bits
argBits :: [CgRep] -> [Bool]
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
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
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE
= do { let lbl = mkBitmapLabel (getUnique name)
; emitRODataLits "mkLiveness" lbl ( mkWordCLit (fromIntegral size)
: map mkWordCLit bits)
; return (BigLiveness lbl) }
| otherwise
= let
small_bits = case bits of
[] -> 0
[b] -> fromIntegral b
_ -> panic "livenessToAddrMode"
in
return (smallLiveness size small_bits)
smallLiveness :: Int -> StgWord -> Liveness
smallLiveness size small_bits = SmallLiveness bits
where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
isBigLiveness :: Liveness -> Bool
isBigLiveness (BigLiveness _) = True
isBigLiveness (SmallLiveness _) = False
mkLivenessCLit :: Liveness -> CmmLit
mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
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
constructSlowCall
:: [(CgRep,CmmExpr)]
-> (CLabel,
[(CgRep,CmmExpr)],
[(CgRep,CmmExpr)])
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 :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
slowArgs [] = []
slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
where (arg_pat, args, rest) = matchSlowPattern amodes
stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
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
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"
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 :: 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))
}
assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
:: [(CgRep,a)]
-> ([(a, GlobalReg)],
[(CgRep,a)])
assignCallRegs args
= assign_regs args (mkRegTbl [node])
assignPrimOpCallRegs args
= assign_regs args (mkRegTbl_allRegs [])
assignReturnRegs args
| [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
= ([(arg, r)], [])
| otherwise
= assign_regs args (mkRegTbl [])
where
non_void_args = filter ((/= VoidArg).fst) args
assign_regs :: [(CgRep,a)]
-> AvailRegs
-> ([(a, GlobalReg)], [(CgRep, a)])
assign_regs args supply
= go args [] supply
where
go [] acc _ = (acc, [])
go ((VoidArg,_) : args) acc supply
= go args acc supply
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)
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))
assign_reg _ _ = Nothing
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]
, [Int]
, [Int]
, [Int]
)
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
ok_float = mapCatMaybes (select FloatReg) floats
ok_double = mapCatMaybes (select DoubleReg) doubles
ok_long = mapCatMaybes (select LongReg) longs
select :: (Int -> GlobalReg) -> Int -> Maybe Int
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"