1 files changed, 166 insertions, 0 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
new file mode 100644
index 0000000000..c3c1148f26
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -0,0 +1,166 @@
+
+-- | Utils for calculating general worst, bound, squeese and free, functions.
+--
+--	as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
+--		Michael Smith, Normal Ramsey, Glenn Holloway.
+--		PLDI 2004
+--	
+--	These general versions are not used in GHC proper because they are too slow.
+--	Instead, hand written optimised versions are provided for each architecture
+--	in MachRegs*.hs 
+--
+--	This code is here because we can test the architecture specific code against it.
+--
+
+module RegAlloc.Graph.ArchBase (
+	RegClass(..),
+	Reg(..),
+	RegSub(..),
+	
+	worst,
+	bound,
+	squeese
+)
+	
+where
+
+-----
+import UniqSet
+import Unique
+
+
+-- Some basic register classes.
+--	These aren't nessesarally in 1-to-1 correspondance with the allocatable
+--	RegClasses in MachRegs.hs
+--
+data RegClass
+	-- general purpose regs
+	= ClassG32	-- 32 bit GPRs
+	| ClassG16	-- 16 bit GPRs
+	| ClassG8	-- 8  bit GPRs
+	
+	-- floating point regs
+	| ClassF64	-- 64 bit FPRs
+	deriving (Show, Eq, Enum)
+
+
+-- | A register of some class
+data Reg
+	-- a register of some class
+	= Reg RegClass Int
+	
+	-- a sub-component of one of the other regs
+	| RegSub RegSub Reg
+	deriving (Show, Eq)
+
+
+-- | so we can put regs in UniqSets
+instance Uniquable Reg where
+	getUnique (Reg c i)
+	 = mkUnique 'R'
+	 $ fromEnum c * 1000 + i
+
+	getUnique (RegSub s (Reg c i))
+	 = mkUnique 'S'
+	 $ fromEnum s * 10000 + fromEnum c * 1000 + i
+
+	getUnique (RegSub _ (RegSub _ _))
+	  = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
+
+-- | A subcomponent of another register
+data RegSub
+	= SubL16	-- lowest 16 bits
+	| SubL8		-- lowest  8 bits
+	| SubL8H	-- second lowest 8 bits
+	deriving (Show, Enum, Ord, Eq)
+	
+
+-- | Worst case displacement
+--
+--	a node N of classN has some number of neighbors, 
+--	all of which are from classC.
+--
+--	(worst neighbors classN classC) is the maximum number of potential
+--	colors for N that can be lost by coloring its neighbors.
+
+-- This should be hand coded/cached for each particular architecture,
+--	because the compute time is very long..
+
+worst 
+	:: (RegClass 	-> UniqSet Reg)
+	-> (Reg 	-> UniqSet Reg)
+	-> Int -> RegClass -> RegClass -> Int
+
+worst regsOfClass regAlias neighbors classN classC
+ = let	regAliasS regs	= unionManyUniqSets
+ 			$ map regAlias
+			$ uniqSetToList regs
+
+	-- all the regs in classes N, C
+ 	regsN		= regsOfClass classN
+	regsC		= regsOfClass classC
+	
+	-- all the possible subsets of c which have size < m
+	regsS		= filter (\s -> sizeUniqSet s >= 1 && sizeUniqSet s <= neighbors)
+			$ powersetLS regsC
+
+	-- for each of the subsets of C, the regs which conflict with posiblities for N
+	regsS_conflict 
+		= map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
+
+  in	maximum $ map sizeUniqSet $ regsS_conflict
+
+
+-- | For a node N of classN and neighbors of classesC
+--	(bound classN classesC) is the maximum number of potential 
+--	colors for N that can be lost by coloring its neighbors.
+--
+
+bound 
+	:: (RegClass 	-> UniqSet Reg)
+	-> (Reg		-> UniqSet Reg)
+	-> RegClass -> [RegClass] -> Int
+
+bound regsOfClass regAlias classN classesC
+ = let	regAliasS regs	= unionManyUniqSets
+ 			$ map regAlias
+			$ uniqSetToList regs
+ 
+ 	regsC_aliases
+		= unionManyUniqSets
+		$ map (regAliasS . regsOfClass) classesC
+
+	overlap	= intersectUniqSets (regsOfClass classN) regsC_aliases
+   
+   in	sizeUniqSet overlap
+
+
+-- | The total squeese on a particular node with a list of neighbors.
+--
+--	A version of this should be constructed for each particular architecture,
+--	possibly including uses of bound, so that alised registers don't get counted
+--	twice, as per the paper.
+--	
+squeese 
+	:: (RegClass	-> UniqSet Reg)
+	-> (Reg		-> UniqSet Reg)
+	-> RegClass -> [(Int, RegClass)] -> Int
+
+squeese regsOfClass regAlias classN countCs
+	= sum (map (\(i, classC) -> worst regsOfClass regAlias i classN classC) countCs)
+	
+
+-- | powerset (for lists)
+powersetL :: [a] -> [[a]]
+powersetL 	= map concat . mapM (\x -> [[],[x]])
+	
+-- | powersetLS (list of sets)
+powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
+powersetLS s	= map mkUniqSet $ powersetL $ uniqSetToList s
+
+{-
+-- | unions (for sets)
+unionsS :: Ord a => Set (Set a) -> Set a
+unionsS	ss 	= Set.unions $ Set.toList ss
+-}
+