X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachRegs.lhs;h=beea181c07a29e4bd65235d5f4d86c75e579f1a4;hb=220a12e946b80166d3fe20419091135cef01f668;hp=bc96e9df6f2077a332b82639dd3ea8537b5ae7e7;hpb=95e67967d9abbef73e8d355d0e168759b4ee0590;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachRegs.lhs b/compiler/nativeGen/MachRegs.lhs index bc96e9d..beea181 100644 --- a/compiler/nativeGen/MachRegs.lhs +++ b/compiler/nativeGen/MachRegs.lhs @@ -13,6 +13,13 @@ -- ----------------------------------------------------------------------------- \begin{code} +{-# 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 + #include "nativeGen/NCG.h" module MachRegs ( @@ -26,8 +33,9 @@ module MachRegs ( -- * The 'Reg' type RegNo, - Reg(..), isRealReg, isVirtualReg, + Reg(..), isRealReg, isVirtualReg, renameVirtualReg, RegClass(..), regClass, + trivColorable, getHiVRegFromLo, mkVReg, @@ -36,6 +44,7 @@ module MachRegs ( -- * Machine-dependent register-related stuff allocatableRegs, argRegs, allArgRegs, callClobberedRegs, + allocatableRegsInClass, freeReg, spRel, @@ -92,8 +101,12 @@ import Pretty import Outputable ( Outputable(..), pprPanic, panic ) import qualified Outputable import Unique +import UniqSet import Constants import FastTypes +import UniqFM + +import GHC.Exts #if powerpc_TARGET_ARCH import Data.Word ( Word8, Word16, Word32 ) @@ -353,6 +366,11 @@ data RegClass | RcDouble deriving Eq +instance Uniquable RegClass where + getUnique RcInteger = mkUnique 'L' 0 + getUnique RcFloat = mkUnique 'L' 1 + getUnique RcDouble = mkUnique 'L' 2 + type RegNo = Int data Reg @@ -396,6 +414,15 @@ isVirtualReg (VirtualRegD _) = True isRealReg :: Reg -> Bool isRealReg = not . isVirtualReg +renameVirtualReg :: Unique -> Reg -> Reg +renameVirtualReg u r + = case r of + RealReg _ -> error "renameVirtualReg: can't change unique on a real reg" + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + instance Show Reg where show (RealReg i) = showReg i show (VirtualRegI u) = "%vI_" ++ show u @@ -403,10 +430,131 @@ instance Show Reg where show (VirtualRegF u) = "%vF_" ++ show u show (VirtualRegD u) = "%vD_" ++ show u +instance Outputable RegClass where + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" + instance Outputable Reg where ppr r = Outputable.text (show r) + + +-- trivColorable function for the graph coloring allocator +-- This gets hammered by scanGraph during register allocation, +-- so needs to be fairly efficient. +-- +-- NOTE: This only works for arcitectures with just RcInteger and RcDouble +-- (which are disjoint) ie. x86, x86_64 and ppc +-- + +-- BL 2007/09 +-- Doing a nice fold over the UniqSet makes trivColorable use +-- 32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs. +{- +trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool +trivColorable classN conflicts exclusions + = let + + acc :: Reg -> (Int, Int) -> (Int, Int) + acc r (cd, cf) + = case regClass r of + RcInteger -> (cd+1, cf) + RcDouble -> (cd, cf+1) + _ -> panic "MachRegs.trivColorable: reg class not handled" + + tmp = foldUniqSet acc (0, 0) conflicts + (countInt, countFloat) = foldUniqSet acc tmp exclusions + + squeese = worst countInt classN RcInteger + + worst countFloat classN RcDouble + + in squeese < allocatableRegsInClass classN + +-- | Worst case displacement +-- node N of classN has n neighbors of class C. +-- +-- We currently only have RcInteger and RcDouble, which don't conflict at all. +-- This is a bit boring compared to what's in RegArchX86. +-- +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + RcInteger + -> case classC of + RcInteger -> min n (allocatableRegsInClass RcInteger) + RcDouble -> 0 + + RcDouble + -> case classC of + RcDouble -> min n (allocatableRegsInClass RcDouble) + RcInteger -> 0 +-} + + +-- The number of allocatable regs is hard coded here so we can do a fast comparision +-- in trivColorable. It's ok if these numbers are _less_ than the actual number of +-- free regs, but they can't be more or the register conflict graph won't color. +-- +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing +-- is too slow for us here. +-- +-- Compare MachRegs.freeRegs and MachRegs.h to get these numbers. +-- +#if i386_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER 3# +#define ALLOCATABLE_REGS_DOUBLE 6# +#endif + +#if x86_64_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER 5# +#define ALLOCATABLE_REGS_DOUBLE 2# +#endif + +#if powerpc_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER 16# +#define ALLOCATABLE_REGS_DOUBLE 26# +#endif + +{-# INLINE regClass #-} +trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool +trivColorable classN conflicts exclusions + = {-# SCC "trivColorable" #-} + let + {-# INLINE isSqueesed #-} + isSqueesed cI cF ufm + = case ufm of + NodeUFM _ _ left right + -> case isSqueesed cI cF right of + (# s, cI', cF' #) + -> case s of + False -> isSqueesed cI' cF' left + True -> (# True, cI', cF' #) + + LeafUFM _ reg + -> case regClass reg of + RcInteger + -> case cI +# 1# of + cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #) + + RcDouble + -> case cF +# 1# of + cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE, cI, cF' #) + + EmptyUFM + -> (# False, cI, cF #) + + in case isSqueesed 0# 0# conflicts of + (# False, cI', cF' #) + -> case isSqueesed cI' cF' exclusions of + (# s, _, _ #) -> not s + + (# True, _, _ #) + -> False + + + -- ----------------------------------------------------------------------------- -- Machine-specific register stuff @@ -468,6 +616,7 @@ fake3 = RealReg 11 fake4 = RealReg 12 fake5 = RealReg 13 + -- On x86, we might want to have an 8-bit RegClass, which would -- contain just regs 1-4 (the others don't have 8-bit versions). -- However, we can get away without this at the moment because the @@ -489,6 +638,7 @@ showReg n then regNames !! n else "%unknown_x86_real_reg_" ++ show n + #endif {- @@ -952,6 +1102,25 @@ allocatableRegs = let isFree i = isFastTrue (freeReg i) in filter isFree allMachRegNos + +-- | The number of regs in each class. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. +allocatableRegsInClass :: RegClass -> Int +allocatableRegsInClass cls + = case cls of + RcInteger -> allocatableRegsInteger + RcDouble -> allocatableRegsDouble + +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs + +allocatableRegsDouble + = length $ filter (\r -> regClass r == RcDouble) + $ map RealReg allocatableRegs + + -- these are the regs which we cannot assume stay alive over a -- C call. callClobberedRegs :: [Reg]