X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCallConv.hs;h=f3013cd5a6f4f1bef1bc5da240d586696c712776;hp=b48b7d52b49079029f18c44a91fe3a7bc651b902;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index b48b7d5..f3013cd 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -9,13 +9,12 @@ -- ----------------------------------------------------------------------------- - module CgCallConv ( -- Argument descriptors mkArgDescr, argDescrType, -- Liveness - isBigLiveness, buildContLiveness, mkRegLiveness, + isBigLiveness, mkRegLiveness, smallLiveness, mkLivenessCLit, -- Register assignment @@ -25,35 +24,31 @@ module CgCallConv ( constructSlowCall, slowArgs, slowCallPattern, -- Returns - CtrlReturnConvention(..), - ctrlReturnConvAlg, dataReturnConvPrim, 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 TyCon import Bitmap import Util import StaticFlags +import Module import FastString import Outputable +import Unique import Data.Bits @@ -70,10 +65,10 @@ import Data.Bits ------------------------------------------------------------------------- -- bring in ARG_P, ARG_N, etc. -#include "../includes/StgFun.h" +#include "../includes/rts/storage/FunTypes.h" ------------------------- -argDescrType :: ArgDescr -> Int +argDescrType :: ArgDescr -> StgHalfWord -- The "argument type" RTS field type argDescrType (ArgSpec n) = n argDescrType (ArgGen liveness) @@ -100,7 +95,7 @@ argBits [] = [] argBits (PtrArg : args) = False : argBits args argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args -stdPattern :: [CgRep] -> Maybe Int +stdPattern :: [CgRep] -> Maybe StgHalfWord stdPattern [] = Just ARG_NONE -- just void args, probably stdPattern [PtrArg] = Just ARG_P @@ -126,7 +121,7 @@ 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 other = Nothing +stdPattern _ = Nothing ------------------------------------------------------------------------- @@ -135,11 +130,19 @@ stdPattern other = Nothing -- ------------------------------------------------------------------------- +-- TODO: This along with 'mkArgDescr' should be unified +-- with 'CmmInfo.mkLiveness'. However that would require +-- potentially invasive changes to the 'ClosureInfo' type. +-- For now, 'CmmInfo.mkLiveness' handles only continuations and +-- this one handles liveness everything else. Another distinction +-- between these two is that 'CmmInfo.mkLiveness' information +-- about the stack layout, and this one is information about +-- the heap layout of PAPs. mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness mkLiveness name size bits | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word - = do { let lbl = mkBitmapLabel name - ; emitRODataLits lbl ( mkWordCLit (fromIntegral size) + = do { let lbl = mkBitmapLabel (getUnique name) + ; emitRODataLits "mkLiveness" lbl ( mkWordCLit (fromIntegral size) : map mkWordCLit bits) ; return (BigLiveness lbl) } @@ -147,7 +150,7 @@ mkLiveness name size bits = let small_bits = case bits of [] -> 0 - [b] -> fromIntegral b + [b] -> b _ -> panic "livenessToAddrMode" in return (smallLiveness size small_bits) @@ -186,7 +189,7 @@ mkRegLiveness regs ptrs nptrs 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 @@ -207,7 +210,7 @@ constructSlowCall -- don't forget the zero case constructSlowCall [] - = (mkRtsApFastLabel SLIT("stg_ap_0"), [], []) + = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], []) constructSlowCall amodes = (stg_ap_pat, these, rest) @@ -215,10 +218,6 @@ constructSlowCall amodes stg_ap_pat = mkRtsApFastLabel arg_pat (arg_pat, these, rest) = matchSlowPattern amodes -enterRtsRetLabel arg_pat - | tablesNextToCode = mkRtsRetInfoLabel arg_pat - | otherwise = mkRtsRetLabel arg_pat - -- | '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. @@ -226,30 +225,31 @@ 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 = 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" ------------------------------------------------------------------------- -- @@ -257,29 +257,9 @@ slowCallPattern _ = panic "CgStackery.slowCallPattern" -- ------------------------------------------------------------------------- --- A @CtrlReturnConvention@ says how {\em control} is returned. - -data CtrlReturnConvention - = VectoredReturn Int -- size of the vector table (family size) - | UnvectoredReturn Int -- family size - -ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention -ctrlReturnConvAlg tycon - = case (tyConFamilySize tycon) of - size -> -- we're supposed to know... - if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then - VectoredReturn size - else - UnvectoredReturn size - -- NB: unvectored returns Include size 0 (no constructors), so that - -- the following perverse code compiles (it crashed GHC in 5.02) - -- data T1 - -- data T2 = T2 !T1 Int - -- The only value of type T1 is bottom, which never returns anyway. - 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) @@ -287,7 +267,7 @@ dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void" -- getSequelAmode returns an amode which refers to an info table. The info --- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful +-- 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. @@ -302,65 +282,13 @@ getSequelAmode = 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 _ _ True -> returnFC (CmmLit (CmmLabel mkSeqInfoLabel)) - CaseAlts lbl _ _ False -> returnFC (CmmLit (CmmLabel lbl)) + CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) } ------------------------------------------------------------------------- -- --- Build a liveness mask for the current stack --- -------------------------------------------------------------------------- - --- There are four kinds of things on the stack: --- --- - pointer variables (bound in the environment) --- - non-pointer variables (boudn in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) --- --- We build up a bitmap of non-pointer slots by searching the environment --- for all the pointer variables, and subtracting these from a bitmap --- with initially all bits set (up to the size of the stack frame). - -buildContLiveness :: Name -- Basis for label (only) - -> [VirtualSpOffset] -- Live stack slots - -> FCode Liveness -buildContLiveness name live_slots - = do { stk_usg <- getStkUsage - ; let StackUsage { realSp = real_sp, - frameSp = frame_sp } = stk_usg - - start_sp :: VirtualSpOffset - start_sp = real_sp - retAddrSizeW - -- In a continuation, we want a liveness mask that - -- starts from just after the return address, which is - -- on the stack at real_sp. - - frame_size :: WordOff - frame_size = start_sp - frame_sp - -- real_sp points to the frame-header for the current - -- stack frame, and the end of this frame is frame_sp. - -- The size is therefore real_sp - frame_sp - retAddrSizeW - -- (subtract one for the frame-header = return address). - - rel_slots :: [WordOff] - rel_slots = sortLe (<=) - [ start_sp - ofs -- Get slots relative to top of frame - | ofs <- live_slots ] - - bitmap = intsToReverseBitmap frame_size rel_slots - - ; WARN( not (all (>=0) rel_slots), - ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots ) - mkLiveness name frame_size bitmap } - - -------------------------------------------------------------------------- --- -- Register assignment -- ------------------------------------------------------------------------- @@ -401,9 +329,22 @@ assignPrimOpCallRegs args -- 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 @@ -411,9 +352,9 @@ assign_regs :: [(CgRep,a)] -- Arg or result values to assign 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' @@ -423,10 +364,10 @@ 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, (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 ------------------------------------------------------------------------- @@ -441,12 +382,16 @@ assign_reg other not_enough_regs = 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 @@ -462,7 +407,7 @@ allFloatRegNos = regList mAX_Float_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. @@ -479,14 +424,16 @@ 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 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