Follow vreg/hreg patch in PPC NCG

9 files changed, 127 insertions, 62 deletions

diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index d3ec27f45c..8eb515e6bf 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -35,6 +35,7 @@ import PIC
 import Size
 import RegClass
 import Reg
+import TargetReg
 import Platform
 
 -- Our intermediate code:
@@ -176,11 +177,11 @@ swizzleRegisterRep (Any _ codefn)     size = Any   size codefn
 getRegisterReg :: CmmReg -> Reg
 
 getRegisterReg (CmmLocal (LocalReg u pk))
-  = mkVReg u (cmmTypeSize pk)
+  = RegVirtual $ mkVirtualReg u (cmmTypeSize pk)
 
 getRegisterReg (CmmGlobal mid)
   = case get_GlobalReg_reg_or_addr mid of
-       Left reg@(RegReal _) -> reg
+       Left reg -> reg
        _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
           -- By this stage, the only MagicIds remaining should be the
           -- ones which map to a real machine register on this
@@ -305,7 +306,7 @@ assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
    ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
    let 
-         r_dst_lo = mkVReg u_dst II32
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
          r_dst_hi = getHiVRegFromLo r_dst_lo
          r_src_hi = getHiVRegFromLo r_src_lo
          mov_lo = MR r_dst_lo r_src_lo
@@ -329,7 +330,7 @@ iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
                          rlo
 
 iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
-   = return (ChildCode64 nilOL (mkVReg vu II32))
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
 
 iselExpr64 (CmmLit (CmmInt i _)) = do
   (rlo,rhi) <- getNewRegPairNat II32
@@ -413,7 +414,7 @@ getRegister (CmmLoad mem pk)
   | not (isWord64 pk)
   = do
         Amode addr addr_code <- getAmode mem
-        let code dst = ASSERT((regClass dst == RcDouble) == isFloatType pk)
+        let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk)
                        addr_code `snocOL` LD size dst addr
         return (Any size code)
           where size = cmmTypeSize pk
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 58ddc21d40..d4d809825d 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -22,6 +22,7 @@ import PPC.Regs
 import PPC.Cond
 import Instruction
 import Size
+import TargetReg
 import RegClass
 import Reg
 
@@ -353,7 +354,7 @@ ppc_mkSpillInstr
 ppc_mkSpillInstr reg delta slot
   = let	off     = spillSlotToOffset slot
     in
-    let sz = case regClass reg of
+    let sz = case targetClassOfReg reg of
                 RcInteger -> II32
                 RcDouble  -> FF64
 		_	  -> panic "PPC.Instr.mkSpillInstr: no match"
@@ -369,7 +370,7 @@ ppc_mkLoadInstr
 ppc_mkLoadInstr reg delta slot
   = let off     = spillSlotToOffset slot
     in
-    let sz = case regClass reg of
+    let sz = case targetClassOfReg reg of
                 RcInteger -> II32
                 RcDouble  -> FF64
 		_         -> panic "PPC.Instr.mkLoadInstr: no match"
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 8378dd17d3..ec6d941191 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -31,6 +31,7 @@ import Instruction
 import Size
 import Reg
 import RegClass
+import TargetReg
 
 import BlockId
 import Cmm
@@ -469,7 +470,7 @@ pprInstr (MR reg1 reg2)
     | reg1 == reg2 = empty
     | otherwise = hcat [
 	char '\t',
-	case regClass reg1 of
+	case targetClassOfReg reg1 of
 	    RcInteger -> ptext (sLit "mr")
 	    _ -> ptext (sLit "fmr"),
 	char '\t',
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index 719d76c316..37de7522f6 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -7,14 +7,11 @@
 -----------------------------------------------------------------------------
 
 module PPC.RegInfo (
-	mkVReg,
-
         JumpDest, 
 	canShortcut, 
 	shortcutJump, 
 
-	shortcutStatic,
-	regDotColor
+	shortcutStatic
 )
 
 where
@@ -24,28 +21,12 @@ where
 
 import PPC.Regs
 import PPC.Instr
-import RegClass
-import Reg
-import Size
 
 import BlockId
 import Cmm
 import CLabel
 
 import Outputable
-import Unique
-
-mkVReg :: Unique -> Size -> Reg
-mkVReg u size
-   | not (isFloatSize size) = RegVirtual $ VirtualRegI u
-   | otherwise
-   = case size of
-        FF32	-> RegVirtual $ VirtualRegD u
-        FF64	-> RegVirtual $ VirtualRegD u
-	_	-> panic "mkVReg"
-
-
-
 
 data JumpDest = DestBlockId BlockId | DestImm Imm
 
@@ -84,11 +65,3 @@ shortBlockId fn blockid@(BlockId uq) =
       Just (DestImm (ImmCLbl lbl)) -> lbl
       _other -> panic "shortBlockId"
 
-
-
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = case regClass reg of
- 	RcInteger	-> text "blue"
-	RcFloat		-> text "red"
-	RcDouble	-> text "green"
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index c39313a6f2..467ea49786 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -5,6 +5,13 @@
 -- -----------------------------------------------------------------------------
 
 module PPC.Regs (
+	-- squeeze functions
+	virtualRegSqueeze,
+	realRegSqueeze,
+
+	mkVirtualReg,
+	regDotColor,
+
 	-- immediates
 	Imm(..),
 	strImmLit,
@@ -20,7 +27,7 @@ module PPC.Regs (
 	allArgRegs,
 	callClobberedRegs,
 	allMachRegNos,
-	regClass,
+	classOfRealReg,
 	showReg,
 	
 	-- machine specific
@@ -46,21 +53,107 @@ where
 
 import Reg
 import RegClass
+import Size
 
 import CgUtils          ( get_GlobalReg_addr )
 import BlockId
 import Cmm
 import CLabel           ( CLabel )
+import Unique
+
 import Pretty
-import Outputable	( Outputable(..), pprPanic, panic )
+import Outputable       ( panic, SDoc )	
 import qualified Outputable
 import Constants
 import FastBool
+import FastTypes
 
 import Data.Word	( Word8, Word16, Word32 )
 import Data.Int 	( Int8, Int16, Int32 )
 
 
+-- squeese functions for the graph allocator -----------------------------------
+
+-- | regSqueeze_class reg
+--	Calculuate the maximum number of register colors that could be
+--	denied to a node of this class due to having this reg 
+--	as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt
+virtualRegSqueeze cls vr
+ = case cls of
+ 	RcInteger
+	 -> case vr of
+	 	VirtualRegI{}		-> _ILIT(1)
+		VirtualRegHi{}		-> _ILIT(1)
+		VirtualRegD{}		-> _ILIT(0)
+		VirtualRegF{}		-> _ILIT(0)
+
+	-- We don't use floats on this arch, but we can't
+	--	return error because the return type is unboxed...
+	RcFloat
+	 -> case vr of
+	 	VirtualRegI{}		-> _ILIT(0)
+		VirtualRegHi{}		-> _ILIT(0)
+		VirtualRegD{}		-> _ILIT(0)
+		VirtualRegF{}		-> _ILIT(0)
+
+	RcDouble
+	 -> case vr of
+	 	VirtualRegI{}		-> _ILIT(0)
+		VirtualRegHi{}		-> _ILIT(0)
+		VirtualRegD{}		-> _ILIT(1)
+		VirtualRegF{}		-> _ILIT(0)
+
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> FastInt
+realRegSqueeze cls rr
+ = case cls of
+ 	RcInteger
+	 -> case rr of
+	 	RealRegSingle regNo
+			| regNo	< 32	-> _ILIT(1)	-- first fp reg is 32 
+			| otherwise	-> _ILIT(0)
+			
+		RealRegPair{}		-> _ILIT(0)
+
+	-- We don't use floats on this arch, but we can't
+	--	return error because the return type is unboxed...
+	RcFloat
+	 -> case rr of
+	 	RealRegSingle regNo
+			| regNo	< 32	-> _ILIT(0)
+			| otherwise	-> _ILIT(0)
+			
+		RealRegPair{}		-> _ILIT(0)
+
+	RcDouble
+	 -> case rr of
+	 	RealRegSingle regNo
+			| regNo	< 32	-> _ILIT(0)
+			| otherwise	-> _ILIT(1)
+			
+		RealRegPair{}		-> _ILIT(0)
+
+mkVirtualReg :: Unique -> Size -> VirtualReg
+mkVirtualReg u size
+   | not (isFloatSize size) = VirtualRegI u
+   | otherwise
+   = case size of
+        FF32    -> VirtualRegD u
+        FF64    -> VirtualRegD u
+        _       -> panic "mkVirtualReg"
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = case classOfRealReg reg of
+        RcInteger       -> Outputable.text "blue"
+        RcFloat         -> Outputable.text "red"
+        RcDouble        -> Outputable.text "green"
+
+
 -- immediates ------------------------------------------------------------------
 data Imm
 	= ImmInt	Int
@@ -173,18 +266,13 @@ allMachRegNos 	:: [RegNo]
 allMachRegNos	= [0..63]
 
 
-{-# INLINE regClass      #-}
-regClass :: Reg -> RegClass
-regClass (RegVirtual (VirtualRegI  _)) = RcInteger
-regClass (RegVirtual (VirtualRegHi _)) = RcInteger
-regClass (RegVirtual (VirtualRegF  u)) = pprPanic ("regClass(ppc):VirtualRegF ") (ppr u)
-regClass (RegVirtual (VirtualRegD  _)) = RcDouble
-
-regClass (RegReal    (RealRegSingle i))
+{-# INLINE classOfRealReg      #-}
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg (RealRegSingle i)
 	| i < 32	= RcInteger 
 	| otherwise	= RcDouble
 
-regClass (RegReal    (RealRegPair{}))
+classOfRealReg (RealRegPair{})
 	= panic "regClass(ppr): no reg pairs on this architecture"
 
 showReg :: RegNo -> String
@@ -541,7 +629,7 @@ get_GlobalReg_reg_or_addr mid
 -- allocatableRegs is allMachRegNos with the fixed-use regs removed.
 -- i.e., these are the regs for which we are prepared to allow the
 -- register allocator to attempt to map VRegs to.
-allocatableRegs :: [RegNo]
+allocatableRegs :: [RealReg]
 allocatableRegs
    = let isFree i = isFastTrue (freeReg i)
-     in  filter isFree allMachRegNos
+     in  map RealRegSingle $ filter isFree allMachRegNos
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
index 878bfe313a..4310c5e5a1 100644
--- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -30,27 +30,31 @@ data FreeRegs = FreeRegs !Word32 !Word32
 noFreeRegs :: FreeRegs
 noFreeRegs = FreeRegs 0 0
 
-releaseReg :: RegNo -> FreeRegs -> FreeRegs
-releaseReg r (FreeRegs g f)
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle r) (FreeRegs g f)
     | r > 31    = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
     | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
+
+releaseReg _ _
+	= panic "RegAlloc.Linear.PPC.releaseReg: bad reg"
     
 initFreeRegs :: FreeRegs
 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
 
-getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]	-- lazilly
 getFreeRegs cls (FreeRegs g f)
     | RcDouble <- cls = go f (0x80000000) 63
     | RcInteger <- cls = go g (0x80000000) 31
     | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)
     where
         go _ 0 _ = []
-        go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
+        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
                  | otherwise    = go x (m `shiftR` 1) $! i-1
 
-allocateReg :: RegNo -> FreeRegs -> FreeRegs
-allocateReg r (FreeRegs g f) 
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs g f) 
     | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
     | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
 
-
+allocateReg _ _
+	= panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs
index f2ed63226c..1a8d88380d 100644
--- a/compiler/nativeGen/TargetReg.hs
+++ b/compiler/nativeGen/TargetReg.hs
@@ -39,7 +39,6 @@ import qualified X86.RegInfo	as X86
 
 #elif powerpc_TARGET_ARCH
 import qualified PPC.Regs	as PPC
-import qualified PPC.RegInfo	as PPC
 
 #elif sparc_TARGET_ARCH	
 import qualified SPARC.Regs	as SPARC
diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
index f47859e399..3c84641c22 100644
--- a/compiler/nativeGen/X86/RegInfo.hs
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -9,7 +9,6 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
-import X86.Regs
 import Size
 import Reg
 
@@ -18,6 +17,7 @@ import Unique
 
 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 import UniqFM
+import X86.Regs
 #endif
 
 
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 840736fe4d..9f62c25f0a 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -108,12 +108,10 @@ virtualRegSqueeze cls vr
 		VirtualRegD{}		-> _ILIT(1)
 		VirtualRegF{}		-> _ILIT(0)
 
-
+realRegSqueeze :: RegClass -> RealReg -> FastInt
 
 #if defined(i386_TARGET_ARCH)
 {-# INLINE realRegSqueeze #-}
-realRegSqueeze :: RegClass -> RealReg -> FastInt
-
 realRegSqueeze cls rr
  = case cls of
  	RcInteger
@@ -172,7 +170,7 @@ realRegSqueeze cls rr
 		RealRegPair{}		-> _ILIT(0)
 
 #else
-realRegSqueeze	= _ILIT(0)
+realRegSqueeze _ _	= _ILIT(0)
 #endif