-- -----------------------------------------------------------------------------
\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 (
+ -- * Sizes
+ Size(..), intSize, floatSize, isFloatSize,
+ wordSize, cmmTypeSize, sizeToWidth,
+
-- * Immediate values
Imm(..), strImmLit, litToImm,
-- * Machine-dependent register-related stuff
allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
+ allocatableRegsInClass,
freeReg,
spRel,
addrModeRegs, allFPArgRegs,
#endif
#if sparc_TARGET_ARCH
- fits13Bits,
- fpRel, gReg, iReg, lReg, oReg, largeOffsetError,
+ fits13Bits,
+ fpRel, gReg, iReg, lReg, oReg, fReg, largeOffsetError,
fp, sp, g0, g1, g2, o0, o1, f0, f6, f8, f26, f27,
#endif
#if powerpc_TARGET_ARCH
-- HACK: go for the max
#endif
-#include "MachRegs.h"
+#include "../includes/MachRegs.h"
+import BlockId
import Cmm
-import MachOp ( MachRep(..) )
import CgUtils ( get_GlobalReg_addr )
-
import CLabel ( CLabel, mkMainCapabilityLabel )
import Pretty
import Outputable ( Outputable(..), pprPanic, panic )
import UniqSet
import Constants
import FastTypes
+import FastBool
+import UniqFM
#if powerpc_TARGET_ARCH
import Data.Word ( Word8, Word16, Word32 )
#endif
-- -----------------------------------------------------------------------------
+-- Sizes on this architecture
+--
+-- A Size is usually a combination of width and class
+
+-- It looks very like the old MachRep, but it's now of purely local
+-- significance, here in the native code generator. You can change it
+-- without global consequences.
+--
+-- A major use is as an opcode qualifier; thus the opcode
+-- mov.l a b
+-- might be encoded
+-- MOV II32 a b
+-- where the Size field encodes the ".l" part.
+
+-- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes
+-- here. I've removed them from the x86 version, we'll see what happens --SDM
+
+-- ToDo: quite a few occurrences of Size could usefully be replaced by Width
+
+#if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH
+data Size -- For these three, the "size" also gives the int/float
+ -- distinction, because the instructions for int/float
+ -- differ only in their suffices
+ = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80
+ deriving Eq
+
+intSize, floatSize :: Width -> Size
+intSize W8 = II8
+intSize W16 = II16
+intSize W32 = II32
+intSize W64 = II64
+intSize other = pprPanic "MachInstrs.intSize" (ppr other)
+
+floatSize W32 = FF32
+floatSize W64 = FF64
+floatSize other = pprPanic "MachInstrs.intSize" (ppr other)
+
+wordSize :: Size
+wordSize = intSize wordWidth
+
+sizeToWidth :: Size -> Width
+sizeToWidth II8 = W8
+sizeToWidth II16 = W16
+sizeToWidth II32 = W32
+sizeToWidth II64 = W64
+sizeToWidth FF32 = W32
+sizeToWidth FF64 = W64
+sizeToWidth _ = panic "MachInstrs.sizeToWidth"
+
+cmmTypeSize :: CmmType -> Size
+cmmTypeSize ty | isFloatType ty = floatSize (typeWidth ty)
+ | otherwise = intSize (typeWidth ty)
+
+isFloatSize :: Size -> Bool
+isFloatSize FF32 = True
+isFloatSize FF64 = True
+isFloatSize FF80 = True
+isFloatSize other = False
+#endif
+
+#if alpha_TARGET_ARCH
+data Size
+ = B -- byte
+ | Bu
+-- | W -- word (2 bytes): UNUSED
+-- | Wu -- : UNUSED
+ | L -- longword (4 bytes)
+ | Q -- quadword (8 bytes)
+-- | FF -- VAX F-style floating pt: UNUSED
+-- | GF -- VAX G-style floating pt: UNUSED
+-- | DF -- VAX D-style floating pt: UNUSED
+-- | SF -- IEEE single-precision floating pt: UNUSED
+ | TF -- IEEE double-precision floating pt
+ deriving Eq
+#endif
+
+#if sparc_TARGET_ARCH /* || powerpc_TARGET_ARCH */
+data Size
+ = II8 -- byte (signed)
+-- | II8u -- byte (unsigned)
+ | II16 -- halfword (signed, 2 bytes)
+-- | II16u -- halfword (unsigned, 2 bytes)
+ | II32 -- word (4 bytes)
+ | II64 -- word (8 bytes)
+ | FF32 -- IEEE single-precision floating pt
+ | FF64 -- IEEE single-precision floating pt
+ deriving Eq
+
+
+intSize, floatSize :: Width -> Size
+intSize W8 = II8
+--intSize W16 = II16u
+intSize W16 = II16
+intSize W32 = II32
+intSize W64 = II64
+intSize other = pprPanic "MachInstrs.intSize" (ppr other)
+
+floatSize W32 = FF32
+floatSize W64 = FF64
+floatSize other = pprPanic "MachInstrs.intSize" (ppr other)
+
+wordSize :: Size
+wordSize = intSize wordWidth
+
+isFloatSize :: Size -> Bool
+isFloatSize FF32 = True
+isFloatSize FF64 = True
+isFloatSize _ = False
+
+cmmTypeSize :: CmmType -> Size
+cmmTypeSize ty | isFloatType ty = floatSize (typeWidth ty)
+ | otherwise = intSize (typeWidth ty)
+
+sizeToWidth :: Size -> Width
+sizeToWidth size
+ = case size of
+ II8 -> W8
+-- II8u -> W8
+ II16 -> W16
+-- II16u -> W16
+ II32 -> W32
+ II64 -> W64
+ FF32 -> W32
+ FF64 -> W64
+
+
+#endif
+
+-- -----------------------------------------------------------------------------
-- Immediates
data Imm
strImmLit s = ImmLit (text s)
litToImm :: CmmLit -> Imm
-litToImm (CmmInt i _) = ImmInteger i
-litToImm (CmmFloat f F32) = ImmFloat f
-litToImm (CmmFloat f F64) = ImmDouble f
+litToImm (CmmInt i w) = ImmInteger (narrowS w i)
+ -- narrow to the width: a CmmInt might be out of
+ -- range, but we assume that ImmInteger only contains
+ -- in-range values. A signed value should be fine here.
+litToImm (CmmFloat f W32) = ImmFloat f
+litToImm (CmmFloat f W64) = ImmDouble f
litToImm (CmmLabel l) = ImmCLbl l
litToImm (CmmLabelOff l off) = ImmIndex l off
litToImm (CmmLabelDiffOff l1 l2 off)
= ImmConstantSum
(ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
(ImmInt off)
+litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id)
-- -----------------------------------------------------------------------------
-- Addressing modes
fits16Bits :: Integral a => a -> Bool
fits16Bits x = x >= -32768 && x < 32768
-makeImmediate :: Integral a => MachRep -> Bool -> a -> Maybe Imm
-
+makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)
where
- narrow I32 False = fromIntegral (fromIntegral x :: Word32)
- narrow I16 False = fromIntegral (fromIntegral x :: Word16)
- narrow I8 False = fromIntegral (fromIntegral x :: Word8)
- narrow I32 True = fromIntegral (fromIntegral x :: Int32)
- narrow I16 True = fromIntegral (fromIntegral x :: Int16)
- narrow I8 True = fromIntegral (fromIntegral x :: Int8)
+ narrow W32 False = fromIntegral (fromIntegral x :: Word32)
+ narrow W16 False = fromIntegral (fromIntegral x :: Word16)
+ narrow W8 False = fromIntegral (fromIntegral x :: Word8)
+ narrow W32 True = fromIntegral (fromIntegral x :: Int32)
+ narrow W16 True = fromIntegral (fromIntegral x :: Int16)
+ narrow W8 True = fromIntegral (fromIntegral x :: Int8)
narrowed = narrow rep signed
- toI16 I32 True
+ toI16 W32 True
| narrowed >= -32768 && narrowed < 32768 = Just narrowed
| otherwise = Nothing
- toI16 I32 False
+ toI16 W32 False
| narrowed >= 0 && narrowed < 65536 = Just narrowed
| otherwise = Nothing
toI16 _ _ = Just narrowed
unRealReg (RealReg i) = i
unRealReg vreg = pprPanic "unRealReg on VirtualReg" (ppr vreg)
-mkVReg :: Unique -> MachRep -> Reg
-mkVReg u rep
- = case rep of
+mkVReg :: Unique -> Size -> Reg
+mkVReg u size
+ | not (isFloatSize size) = VirtualRegI u
+ | otherwise
+ = case size of
#if sparc_TARGET_ARCH
- F32 -> VirtualRegF u
+ FF32 -> VirtualRegF u
+ FF64 -> VirtualRegD u
#else
- F32 -> VirtualRegD u
+ FF32 -> VirtualRegD u
+ FF64 -> VirtualRegD u
#endif
- F64 -> VirtualRegD u
- other -> VirtualRegI u
+ _other -> panic "mkVReg"
isVirtualReg :: Reg -> Bool
isVirtualReg (RealReg _) = False
-- 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
+ = 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
- (rsD, rsFP) = foldUniqSet acc tmp exclusions
+ tmp = foldUniqSet acc (0, 0) conflicts
+ (countInt, countFloat) = foldUniqSet acc tmp exclusions
- squeese = worst rsD classN RcInteger
- + worst rsFP classN RcDouble
+ 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.
--
-> 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 (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
+
+#elif x86_64_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2))
+
+#elif powerpc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26))
+
+#elif sparc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
+
+#else
+#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE
+#endif
+
+{-# INLINE regClass #-}
+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
+trivColorable classN conflicts exclusions
+ = {-# SCC "trivColorable" #-}
+ let
+ 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 +# _ILIT(1) of
+ cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #)
+
+ RcDouble
+ -> case cF +# _ILIT(1) of
+ cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE, cI, cF' #)
+
+ EmptyUFM
+ -> (# False, cI, cF #)
+
+ in case isSqueesed (_ILIT(0)) (_ILIT(0)) conflicts of
+ (# False, cI', cF' #)
+ -> case isSqueesed cI' cF' exclusions of
+ (# s, _, _ #) -> not s
+
+ (# True, _, _ #)
+ -> False
+
-- -----------------------------------------------------------------------------
nCG_FirstFloatReg :: RegNo
nCG_FirstFloatReg = unRealReg NCG_FirstFloatReg
-regClass (VirtualRegI u) = RcInteger
-regClass (VirtualRegF u) = RcFloat
-regClass (VirtualRegD u) = RcDouble
+regClass (VirtualRegI u) = RcInteger
+regClass (VirtualRegHi u) = RcInteger
+regClass (VirtualRegF u) = RcFloat
+regClass (VirtualRegD u) = RcDouble
regClass (RealReg i) | i < 32 = RcInteger
| i < nCG_FirstFloatReg = RcDouble
| otherwise = RcFloat
#if sparc_TARGET_ARCH
freeReg g0 = fastBool False -- %g0 is always 0.
+
freeReg g5 = fastBool False -- %g5 is reserved (ABI).
freeReg g6 = fastBool False -- %g6 is reserved (ABI).
freeReg g7 = fastBool False -- %g7 is reserved (ABI).
freeReg o7 = fastBool False -- %o7 holds ret addrs (???)
freeReg f0 = fastBool False -- %f0/%f1 are the C fp return registers.
freeReg f1 = fastBool False
+
+-- TODO: Not sure about these BL 2009/01/10
+-- Used for NCG spill tmps? what is this?
+
+{-
+freeReg g1 = fastBool False -- %g1 is used for NCG spill tmp
+freeReg g2 = fastBool False
+freeReg f6 = fastBool False
+freeReg f8 = fastBool False
+freeReg f26 = fastBool False
+freeReg f27 = fastBool False
+-}
+
#endif
#if powerpc_TARGET_ARCH
globalRegMaybe BaseReg = Just (RealReg REG_Base)
#endif
#ifdef REG_R1
-globalRegMaybe (VanillaReg 1) = Just (RealReg REG_R1)
+globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1)
#endif
#ifdef REG_R2
-globalRegMaybe (VanillaReg 2) = Just (RealReg REG_R2)
+globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2)
#endif
#ifdef REG_R3
-globalRegMaybe (VanillaReg 3) = Just (RealReg REG_R3)
+globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3)
#endif
#ifdef REG_R4
-globalRegMaybe (VanillaReg 4) = Just (RealReg REG_R4)
+globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4)
#endif
#ifdef REG_R5
-globalRegMaybe (VanillaReg 5) = Just (RealReg REG_R5)
+globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5)
#endif
#ifdef REG_R6
-globalRegMaybe (VanillaReg 6) = Just (RealReg REG_R6)
+globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6)
#endif
#ifdef REG_R7
-globalRegMaybe (VanillaReg 7) = Just (RealReg REG_R7)
+globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7)
#endif
#ifdef REG_R8
-globalRegMaybe (VanillaReg 8) = Just (RealReg REG_R8)
+globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8)
#endif
#ifdef REG_R9
-globalRegMaybe (VanillaReg 9) = Just (RealReg REG_R9)
+globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9)
#endif
#ifdef REG_R10
-globalRegMaybe (VanillaReg 10) = Just (RealReg REG_R10)
+globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10)
#endif
#ifdef REG_F1
globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1)