--
-----------------------------------------------------------------------------
-
module CgCallConv (
-- Argument descriptors
mkArgDescr, argDescrType,
getSequelAmode
) where
-#include "HsVersions.h"
-
import CgUtils
import CgMonad
import SMRep
-import MachOp
-import Cmm
+import OldCmm
import CLabel
import Constants
import ClosureInfo
import CgStackery
-import CmmUtils
+import OldCmmUtils
import Maybes
import Id
import Name
import Bitmap
import Util
import StaticFlags
+import Module
import FastString
import Outputable
import Unique
-------------------------------------------------------------------------
-- bring in ARG_P, ARG_N, etc.
-#include "../includes/StgFun.h"
+#include "../includes/rts/storage/FunTypes.h"
-------------------------
argDescrType :: ArgDescr -> StgHalfWord
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 other = Nothing
+stdPattern _ = Nothing
-------------------------------------------------------------------------
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
= do { let lbl = mkBitmapLabel (getUnique name)
- ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
+ ; emitRODataLits "mkLiveness" lbl ( mkWordCLit (fromIntegral size)
: map mkWordCLit bits)
; return (BigLiveness lbl) }
= let
small_bits = case bits of
[] -> 0
- [b] -> fromIntegral b
+ [b] -> b
_ -> panic "livenessToAddrMode"
in
return (smallLiveness size small_bits)
all_non_ptrs = 0xff
reg_bits [] = 0
- reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
+ reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
= (1 `shiftL` (i - 1)) .|. reg_bits regs
reg_bits (_ : regs)
= reg_bits regs
-- don't forget the zero case
constructSlowCall []
- = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
+ = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
constructSlowCall amodes
= (stg_ap_pat, these, rest)
slowArgs [] = []
slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
where (arg_pat, args, rest) = matchSlowPattern amodes
- stg_ap_pat = mkRtsRetInfoLabel arg_pat
+ stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
matchSlowPattern :: [(CgRep,CmmExpr)]
- -> (LitString, [(CgRep,CmmExpr)], [(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 (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3)
-slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2)
-slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2)
-slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1)
-slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1)
-slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1)
-slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1)
-slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1)
-slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1)
-slowCallPattern _ = panic "CgStackery.slowCallPattern"
+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)
-dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
+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)
= do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
; case sequel of
OnStack -> do { sp_rel <- getSpRelOffset virt_sp
- ; returnFC (CmmLoad sp_rel wordRep) }
+ ; returnFC (CmmLoad sp_rel bWord) }
- UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
}
-- For primops, *all* arguments must be passed in registers
assignReturnRegs args
- = assign_regs args (mkRegTbl [])
+ -- 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
assign_regs args supply
= go args [] supply
where
- go [] acc supply = (acc, []) -- Return the results reversed (doesn't matter)
+ 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 nothign to bind them to
+ = 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'
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, (vs, fs, ds, ls))
-assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (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 other not_enough_regs = Nothing
+assign_reg _ _ = Nothing
-------------------------------------------------------------------------
-- 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
allDoubleRegNos = regList mAX_Double_REG
allLongRegNos = regList mAX_Long_REG
-regList 0 = []
+regList :: Int -> [Int]
regList n = [1 .. n]
type AvailRegs = ( [Int] -- available vanilla regs.
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 VanillaReg) vanillas
+ 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
- -- rep isn't looked at, hence we can use any old rep.
select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
-- one we've unboxed the Int, we make a GlobalReg
projects / ghc-hetmet.git / blobdiff