Commit f203e63c authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Move more constants into platformConstants

parent 6f3be2b6
......@@ -46,12 +46,12 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
([_], NativeReturn) -> allRegs
([_], NativeReturn) -> allRegs dflags
(_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers
(_, GC) -> allRegs
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, GC) -> allRegs dflags
(_, PrimOpCall) -> allRegs dflags
([_], PrimOpReturn) -> allRegs dflags
(_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers,
......@@ -111,46 +111,51 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- that are guaranteed to map to machine registers.
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
getRegsWithoutNode _dflags =
( filter (\r -> r VGcPtr /= node) realVanillaRegs
, realFloatRegs
, realDoubleRegs
, realLongRegs )
getRegsWithoutNode dflags =
( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode _dflags =
( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
, realFloatRegs
, realDoubleRegs
, realLongRegs )
allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg]
allVanillaRegs = map VanillaReg $ regList mAX_Vanilla_REG
allFloatRegs = map FloatReg $ regList mAX_Float_REG
allDoubleRegs = map DoubleReg $ regList mAX_Double_REG
allLongRegs = map LongReg $ regList mAX_Long_REG
realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
realVanillaRegs :: [VGcPtr -> GlobalReg]
realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
realFloatRegs = map FloatReg $ regList mAX_Real_Float_REG
realDoubleRegs = map DoubleReg $ regList mAX_Real_Double_REG
realLongRegs = map LongReg $ regList mAX_Real_Long_REG
getRegsWithNode dflags =
( if null (realVanillaRegs dflags)
then [VanillaReg 1]
else realVanillaRegs dflags
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
regList :: Int -> [Int]
regList n = [1 .. n]
allRegs :: AvailRegs
allRegs = (allVanillaRegs, allFloatRegs, allDoubleRegs, allLongRegs)
allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
allFloatRegs dflags,
allDoubleRegs dflags,
allLongRegs dflags)
noRegs :: AvailRegs
noRegs = ([], [], [], [])
globalArgRegs :: [GlobalReg]
globalArgRegs = map ($VGcPtr) allVanillaRegs ++
allFloatRegs ++
allDoubleRegs ++
allLongRegs
globalArgRegs :: DynFlags -> [GlobalReg]
globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
allFloatRegs dflags ++
allDoubleRegs dflags ++
allLongRegs dflags
......@@ -34,7 +34,6 @@ import SMRep
import OldCmm
import CLabel
import Constants
import CgStackery
import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
import OldCmmUtils
......@@ -264,7 +263,7 @@ type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign
[(CgRep,a)]) -- Leftover arg or result values
assignCallRegs :: DynFlags -> AssignRegs a
assignPrimOpCallRegs :: AssignRegs a
assignPrimOpCallRegs :: DynFlags -> AssignRegs a
assignReturnRegs :: DynFlags -> AssignRegs a
assignCallRegs dflags args
......@@ -273,8 +272,8 @@ assignCallRegs dflags args
-- never uses Node for argument passing; instead
-- Node points to the function closure itself
assignPrimOpCallRegs args
= assign_regs args (mkRegTbl_allRegs [])
assignPrimOpCallRegs dflags args
= assign_regs args (mkRegTbl_allRegs dflags [])
-- For primops, *all* arguments must be passed in registers
assignReturnRegs dflags args
......@@ -334,19 +333,19 @@ assign_reg _ _ = Nothing
useVanillaRegs :: DynFlags -> Int
useVanillaRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Vanilla_REG
| otherwise = mAX_Real_Vanilla_REG dflags
useFloatRegs :: DynFlags -> Int
useFloatRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Float_REG
| otherwise = mAX_Real_Float_REG dflags
useDoubleRegs :: DynFlags -> Int
useDoubleRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Double_REG
| otherwise = mAX_Real_Double_REG dflags
useLongRegs :: DynFlags -> Int
useLongRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Long_REG
| otherwise = mAX_Real_Long_REG dflags
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
vanillaRegNos dflags = regList $ useVanillaRegs dflags
......@@ -354,11 +353,12 @@ floatRegNos dflags = regList $ useFloatRegs dflags
doubleRegNos dflags = regList $ useDoubleRegs dflags
longRegNos dflags = regList $ useLongRegs dflags
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
allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos
:: DynFlags -> [Int]
allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags
allFloatRegNos dflags = regList $ mAX_Float_REG dflags
allDoubleRegNos dflags = regList $ mAX_Double_REG dflags
allLongRegNos dflags = regList $ mAX_Long_REG dflags
regList :: Int -> [Int]
regList n = [1 .. n]
......@@ -371,25 +371,29 @@ type AvailRegs = ( [Int] -- available vanilla regs.
mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
mkRegTbl dflags regs_in_use
= mkRegTbl' regs_in_use (vanillaRegNos dflags)
(floatRegNos dflags)
(doubleRegNos dflags)
(longRegNos dflags)
mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
mkRegTbl_allRegs regs_in_use
= mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
mkRegTbl' :: [GlobalReg] -> [Int] -> [Int] -> [Int] -> [Int]
= mkRegTbl' dflags regs_in_use
vanillaRegNos floatRegNos doubleRegNos longRegNos
mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs
mkRegTbl_allRegs dflags regs_in_use
= mkRegTbl' dflags regs_in_use
allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
mkRegTbl' :: DynFlags -> [GlobalReg]
-> (DynFlags -> [Int])
-> (DynFlags -> [Int])
-> (DynFlags -> [Int])
-> (DynFlags -> [Int])
-> ([Int], [Int], [Int], [Int])
mkRegTbl' regs_in_use vanillas floats doubles longs
mkRegTbl' dflags 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_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr))
(vanillas dflags)
-- 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
ok_float = mapCatMaybes (select FloatReg) (floats dflags)
ok_double = mapCatMaybes (select DoubleReg) (doubles dflags)
ok_long = mapCatMaybes (select LongReg) (longs dflags)
select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
-- one we've unboxed the Int, we make a GlobalReg
......
......@@ -413,11 +413,12 @@ tailCallPrimCall primcall
tailCallPrim :: CLabel -> [StgArg] -> Code
tailCallPrim lbl args
= do { -- We're going to perform a normal-looking tail call,
= do { dflags <- getDynFlags
-- We're going to perform a normal-looking tail call,
-- except that *all* the arguments will be in registers.
-- Hence the ASSERT( null leftovers )
arg_amodes <- getArgAmodes args
; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes
; arg_amodes <- getArgAmodes args
; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes
live_regs = Just $ map snd arg_regs
jump_to_primop = jumpToLbl lbl live_regs
......
......@@ -299,11 +299,11 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load)
vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ]
-- The VNonGcPtr is a lie, but I don't think it matters
++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
++ [ LongReg n | n <- [0..mAX_Long_REG] ]
++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ]
++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ]
++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ]
callerSaveGlobalReg reg next
| callerSaves platform reg =
......
......@@ -169,15 +169,15 @@ stmtToInstrs stmt = do
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmJump arg gregs -> do dflags <- getDynFlags
let platform = targetPlatform dflags
genJump arg (jumpRegs platform gregs)
genJump arg (jumpRegs dflags gregs)
CmmReturn ->
panic "stmtToInstrs: return statement should have been cps'd away"
jumpRegs :: Platform -> Maybe [GlobalReg] -> [Reg]
jumpRegs platform Nothing = allHaskellArgRegs platform
jumpRegs platform (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
jumpRegs :: DynFlags -> Maybe [GlobalReg] -> [Reg]
jumpRegs dflags Nothing = allHaskellArgRegs dflags
jumpRegs dflags (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
where platform = targetPlatform dflags
--------------------------------------------------------------------------------
-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
......
......@@ -54,6 +54,7 @@ import RegClass
import OldCmm
import CmmCallConv
import CLabel ( CLabel )
import DynFlags
import Outputable
import Platform
import FastTypes
......@@ -440,8 +441,9 @@ instrClobberedRegs platform
--
-- All machine registers that are used for argument-passing to Haskell functions
allHaskellArgRegs :: Platform -> [Reg]
allHaskellArgRegs platform = [ RegReal r | Just r <- map (globalRegMaybe platform) globalArgRegs ]
allHaskellArgRegs :: DynFlags -> [Reg]
allHaskellArgRegs dflags = [ RegReal r | Just r <- map (globalRegMaybe platform) (globalArgRegs dflags) ]
where platform = targetPlatform dflags
-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
-- i.e., these are the regs for which we are prepared to allow the
......
......@@ -34,36 +34,6 @@ mAX_CONTEXT_REDUCTION_DEPTH :: Int
mAX_CONTEXT_REDUCTION_DEPTH = 200
-- Increase to 200; see Trac #5395
-- A section of code-generator-related MAGIC CONSTANTS.
mAX_Vanilla_REG :: Int
mAX_Vanilla_REG = MAX_VANILLA_REG
mAX_Float_REG :: Int
mAX_Float_REG = MAX_FLOAT_REG
mAX_Double_REG :: Int
mAX_Double_REG = MAX_DOUBLE_REG
mAX_Long_REG :: Int
mAX_Long_REG = MAX_LONG_REG
mAX_Real_Vanilla_REG :: Int
mAX_Real_Vanilla_REG = MAX_REAL_VANILLA_REG
mAX_Real_Float_REG :: Int
mAX_Real_Float_REG = MAX_REAL_FLOAT_REG
mAX_Real_Double_REG :: Int
mAX_Real_Double_REG = MAX_REAL_DOUBLE_REG
mAX_Real_Long_REG :: Int
#ifdef MAX_REAL_LONG_REG
mAX_Real_Long_REG = MAX_REAL_LONG_REG
#else
mAX_Real_Long_REG = 0
#endif
-- Closure header sizes.
sTD_HDR_SIZE :: Int
......
......@@ -652,6 +652,22 @@ main(int argc, char *argv[])
constantInt("mUT_ARR_PTRS_CARD_BITS", MUT_ARR_PTRS_CARD_BITS);
// A section of code-generator-related MAGIC CONSTANTS.
constantInt("mAX_Vanilla_REG", MAX_VANILLA_REG);
constantInt("mAX_Float_REG", MAX_FLOAT_REG);
constantInt("mAX_Double_REG", MAX_DOUBLE_REG);
constantInt("mAX_Long_REG", MAX_LONG_REG);
constantInt("mAX_Real_Vanilla_REG", MAX_REAL_VANILLA_REG);
constantInt("mAX_Real_Float_REG", MAX_REAL_FLOAT_REG);
constantInt("mAX_Real_Double_REG", MAX_REAL_DOUBLE_REG);
constantInt("mAX_Real_Long_REG",
#ifdef MAX_REAL_LONG_REG
MAX_REAL_LONG_REG
#else
0
#endif
);
switch (mode) {
case Gen_Haskell_Type:
printf(" } deriving (Read, Show)\n");
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment