X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCallConv.hs;h=f3013cd5a6f4f1bef1bc5da240d586696c712776;hp=87c69b63319a8d92242bb2f36bccbadded7b4aad;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 87c69b6..f3013cd 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004-2006 @@ -39,19 +32,20 @@ import CgUtils import CgMonad import SMRep -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 @@ -71,7 +65,7 @@ import Data.Bits ------------------------------------------------------------------------- -- bring in ARG_P, ARG_N, etc. -#include "../includes/StgFun.h" +#include "../includes/rts/storage/FunTypes.h" ------------------------- argDescrType :: ArgDescr -> StgHalfWord @@ -127,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 ------------------------------------------------------------------------- @@ -156,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) @@ -216,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) @@ -231,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" ------------------------------------------------------------------------- -- @@ -289,7 +284,6 @@ getSequelAmode OnStack -> do { sp_rel <- getSpRelOffset virt_sp ; returnFC (CmmLoad sp_rel bWord) } - UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel)) CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) } @@ -358,7 +352,7 @@ 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 nothing to bind them to go ((rep,arg) : args) acc supply @@ -369,11 +363,11 @@ assign_regs args supply 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) = pprTrace "longArg" (ppr l) $ Just (LongReg l, (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 other not_enough_regs = Nothing +assign_reg _ _ = Nothing ------------------------------------------------------------------------- @@ -388,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 @@ -409,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. @@ -426,6 +424,8 @@ 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