NCG: Move the graph allocator into its own dir

8 files changed, 2108 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
+-}
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
new file mode 100644
index 0000000000..8018f24fd4
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
@@ -0,0 +1,147 @@
+
+-- | A description of the register set of the X86.
+--	This isn't used directly in GHC proper.
+--
+--	See RegArchBase.hs for the reference.
+--	See MachRegs.hs for the actual trivColorable function used in GHC.
+--
+
+module RegAlloc.Graph.ArchX86 (
+	classOfReg,
+	regsOfClass,
+	regName,
+	regAlias,
+	worst,
+	squeese,
+) where
+
+import RegAlloc.Graph.ArchBase	(Reg(..), RegSub(..), RegClass(..))
+
+import UniqSet
+
+-- | Determine the class of a register
+classOfReg :: Reg -> RegClass
+classOfReg reg
+ = case reg of
+	Reg c _		-> c
+	
+	RegSub SubL16 _	-> ClassG16
+	RegSub SubL8  _	-> ClassG8
+	RegSub SubL8H _	-> ClassG8
+
+	
+-- | Determine all the regs that make up a certain class.
+--
+regsOfClass :: RegClass -> UniqSet Reg
+regsOfClass c
+ = case c of
+ 	ClassG32	
+	 -> mkUniqSet	  [ Reg ClassG32  i			| i <- [0..7] ]
+
+	ClassG16	
+	 -> mkUniqSet     [ RegSub SubL16 (Reg ClassG32 i)	| i <- [0..7] ]
+
+	ClassG8	
+	 -> unionUniqSets
+	 	(mkUniqSet [ RegSub SubL8  (Reg ClassG32 i)	| i <- [0..3] ])
+		(mkUniqSet [ RegSub SubL8H (Reg ClassG32 i)	| i <- [0..3] ])
+			
+	ClassF64	
+	 -> mkUniqSet 	   [ Reg ClassF64  i			| i <- [0..5] ]
+	
+
+-- | Determine the common name of a reg
+--	returns Nothing if this reg is not part of the machine.
+	
+regName :: Reg -> Maybe String
+regName reg
+ = case reg of
+ 	Reg ClassG32 i	
+	 | i <= 7	-> Just ([ "eax", "ebx", "ecx", "edx", "ebp", "esi", "edi", "esp" ] !! i)
+
+	RegSub SubL16 (Reg ClassG32 i)
+	 | i <= 7	-> Just ([ "ax", "bx", "cx", "dx", "bp", "si", "di", "sp"] !! i)
+	 
+	RegSub SubL8  (Reg ClassG32 i)
+	 | i <= 3	-> Just ([ "al", "bl", "cl", "dl"] !! i)
+	 
+	RegSub SubL8H (Reg ClassG32 i)
+	 | i <= 3	-> Just ([ "ah", "bh", "ch", "dh"] !! i)
+
+	_		-> Nothing
+
+	
+-- | Which regs alias what other regs
+regAlias :: Reg -> UniqSet Reg
+regAlias reg
+ = case reg of
+
+	-- 32 bit regs alias all of the subregs
+	Reg ClassG32 i
+	 
+	 -- for eax, ebx, ecx, eds
+	 |  i <= 3		
+	 -> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg, RegSub SubL8 reg, RegSub SubL8H reg ]
+	 
+	 -- for esi, edi, esp, ebp
+	 | 4 <= i && i <= 7	
+	 -> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg ]
+	
+	
+	-- 16 bit subregs alias the whole reg
+	RegSub SubL16 r@(Reg ClassG32 _)	
+	 -> 	regAlias r
+	
+	-- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
+	RegSub SubL8  r@(Reg ClassG32 _)
+	 -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
+
+	RegSub SubL8H r@(Reg ClassG32 _)
+	 -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
+	
+	-- fp
+	Reg ClassF64 _	
+	 -> unitUniqSet reg
+
+	_ -> error "regAlias: invalid register"
+
+
+-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
+
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+ 	ClassG32
+	 -> case classC of
+	 	ClassG32	-> min n 8
+		ClassG16	-> min n 8
+		ClassG8		-> min n 4
+		ClassF64	-> 0
+		
+	ClassG16
+	 -> case classC of
+	 	ClassG32	-> min n 8
+		ClassG16	-> min n 8
+		ClassG8		-> min n 4
+		ClassF64	-> 0
+		
+	ClassG8
+	 -> case classC of
+		ClassG32	-> min (n*2) 8
+		ClassG16	-> min (n*2) 8
+	 	ClassG8		-> min n 8
+		ClassF64	-> 0
+		
+	ClassF64
+	 -> case classC of
+	 	ClassF64	-> min n 6
+		_		-> 0
+		
+squeese :: RegClass -> [(Int, RegClass)] -> Int
+squeese classN countCs
+	= sum (map (\(i, classC) -> worst i classN classC) countCs)
+	
+
+
+
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
new file mode 100644
index 0000000000..34e014c54b
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -0,0 +1,83 @@
+-- | Register coalescing.
+--
+
+module RegAlloc.Graph.Coalesce (
+	regCoalesce,
+	slurpJoinMovs
+)
+
+where
+
+import Cmm
+import MachRegs
+import RegLiveness
+import RegAllocInfo
+
+import Bag
+import UniqFM
+import UniqSet
+import UniqSupply
+
+import Control.Monad
+import Data.List
+
+-- | Do register coalescing on this top level thing
+--	For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
+--	then the mov only serves to join live ranges. The two regs can be renamed to be 
+--	the same and the move instruction safely erased.
+
+regCoalesce :: [LiveCmmTop] -> UniqSM [LiveCmmTop]
+regCoalesce code
+ = do	
+ 	let joins	= foldl' unionBags emptyBag
+			$ map slurpJoinMovs code
+
+	let alloc	= foldl' buildAlloc emptyUFM 
+			$ bagToList joins
+
+	let patched	= map (patchEraseLive (sinkReg alloc)) code
+			
+	return patched
+
+
+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
+buildAlloc fm (r1, r2)
+ = let	rmin	= min r1 r2
+ 	rmax	= max r1 r2
+   in	addToUFM fm rmax rmin
+
+sinkReg :: UniqFM Reg -> Reg -> Reg
+sinkReg fm r
+ = case lookupUFM fm r of
+ 	Nothing	-> r
+	Just r'	-> sinkReg fm r'	
+	
+
+-- | Slurp out mov instructions that only serve to join live ranges.
+--	During a mov, if the source reg dies and the destiation reg is born
+--	then we can rename the two regs to the same thing and eliminate the move.
+--
+slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
+slurpJoinMovs live
+	= slurpCmm emptyBag live
+ where	
+  	slurpCmm   rs  CmmData{}		         = rs
+	slurpCmm   rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp  rs blocks
+   	slurpComp  rs (BasicBlock _ blocks)	         = foldl' slurpBlock rs blocks
+        slurpBlock rs (BasicBlock _ instrs)              = foldl' slurpLI    rs instrs
+                
+        slurpLI    rs (Instr _	Nothing)	         = rs
+	slurpLI    rs (Instr instr (Just live))
+	 	| Just (r1, r2)	<- isRegRegMove instr
+		, elementOfUniqSet r1 $ liveDieRead live
+		, elementOfUniqSet r2 $ liveBorn live
+
+		-- only coalesce movs between two virtuals for now, else we end up with
+		--	allocatable regs in the live regs list.. 
+		, isVirtualReg r1 && isVirtualReg r2
+		= consBag (r1, r2) rs
+		
+		| otherwise
+		= rs
+	
+	
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
new file mode 100644
index 0000000000..b7945498b0
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -0,0 +1,367 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
+-- | Graph coloring register allocator.
+--
+-- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer.
+--
+
+module RegAlloc.Graph.Main ( 
+	regAlloc,
+	regDotColor
+) 
+
+where
+
+import qualified GraphColor	as Color
+import RegLiveness
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillClean
+import RegAlloc.Graph.SpillCost
+import RegAlloc.Graph.Stats
+import MachRegs
+import MachInstrs
+import PprMach
+
+import UniqSupply
+import UniqSet
+import UniqFM
+import Bag
+import Outputable
+import DynFlags
+
+import Data.List
+import Data.Maybe
+import Control.Monad
+
+-- | The maximum number of build\/spill cycles we'll allow.
+--	We should only need 3 or 4 cycles tops.
+--	If we run for any longer than this we're probably in an infinite loop,
+--	It's probably better just to bail out and report a bug at this stage.
+maxSpinCount	:: Int
+maxSpinCount	= 10
+
+
+-- | The top level of the graph coloring register allocator.
+--	
+regAlloc
+	:: DynFlags
+	-> UniqFM (UniqSet Reg)		-- ^ the registers we can use for allocation
+	-> UniqSet Int			-- ^ the set of available spill slots.
+	-> [LiveCmmTop]			-- ^ code annotated with liveness information.
+	-> UniqSM ( [NatCmmTop], [RegAllocStats] )
+           -- ^ code with registers allocated and stats for each stage of
+           -- allocation
+		
+regAlloc dflags regsFree slotsFree code
+ = do
+ 	(code_final, debug_codeGraphs, _)
+		<- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
+	
+	return	( code_final
+		, reverse debug_codeGraphs )
+
+regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
+ = do
+ 	-- if any of these dump flags are turned on we want to hang on to
+	--	intermediate structures in the allocator - otherwise tell the
+	--	allocator to ditch them early so we don't end up creating space leaks.
+	let dump = or
+		[ dopt Opt_D_dump_asm_regalloc_stages dflags
+		, dopt Opt_D_dump_asm_stats dflags
+		, dopt Opt_D_dump_asm_conflicts dflags ]
+
+	-- check that we're not running off down the garden path.
+	when (spinCount > maxSpinCount)
+	 $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
+	 	(  text "It looks like the register allocator is stuck in an infinite loop."
+		$$ text "max cycles  = " <> int maxSpinCount
+	 	$$ text "regsFree    = " <> (hcat	$ punctuate space $ map (docToSDoc . pprUserReg)
+						$ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
+		$$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
+
+ 	-- build a conflict graph from the code.
+	graph		<- {-# SCC "BuildGraph" #-} buildGraph code
+
+	-- VERY IMPORTANT:
+	--	We really do want the graph to be fully evaluated _before_ we start coloring.
+	--	If we don't do this now then when the call to Color.colorGraph forces bits of it,
+	--	the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
+	--
+	seqGraph graph `seq` return ()
+
+
+	-- build a map of the cost of spilling each instruction
+	--	this will only actually be computed if we have to spill something.
+	let spillCosts	= foldl' plusSpillCostInfo zeroSpillCostInfo
+			$ map slurpSpillCostInfo code
+
+	-- the function to choose regs to leave uncolored
+	let spill	= chooseSpill spillCosts
+
+	-- record startup state
+	let stat1	=
+		if spinCount == 0
+		 then	Just $ RegAllocStatsStart
+		 	{ raLiveCmm	= code
+			, raGraph	= graph
+			, raSpillCosts	= spillCosts }
+		 else	Nothing
+	
+	-- try and color the graph 
+	let (graph_colored, rsSpill, rmCoalesce)
+			= {-# SCC "ColorGraph" #-}
+			   Color.colorGraph
+			    	(dopt Opt_RegsIterative dflags)
+				spinCount
+			    	regsFree triv spill graph
+
+	-- rewrite regs in the code that have been coalesced
+	let patchF reg	= case lookupUFM rmCoalesce reg of
+				Just reg'	-> patchF reg'
+				Nothing		-> reg
+	let code_coalesced
+			= map (patchEraseLive patchF) code
+
+
+	-- see if we've found a coloring
+	if isEmptyUniqSet rsSpill
+	 then do
+		-- if -fasm-lint is turned on then validate the graph
+		let graph_colored_lint	=
+			if dopt Opt_DoAsmLinting dflags
+				then Color.validateGraph (text "")
+					True 	-- require all nodes to be colored
+					graph_colored
+				else graph_colored
+
+		-- patch the registers using the info in the graph
+	 	let code_patched	= map (patchRegsFromGraph graph_colored_lint) code_coalesced
+
+		-- clean out unneeded SPILL/RELOADs
+		let code_spillclean	= map cleanSpills code_patched
+
+		-- strip off liveness information
+		let code_nat		= map stripLive code_spillclean
+
+		-- rewrite SPILL/RELOAD pseudos into real instructions
+		let spillNatTop		= mapGenBlockTop spillNatBlock
+		let code_final		= map spillNatTop code_nat
+		
+		-- record what happened in this stage for debugging
+		let stat		=
+			RegAllocStatsColored
+			{ raGraph		= graph
+			, raGraphColored	= graph_colored_lint
+			, raCoalesced		= rmCoalesce
+			, raPatched		= code_patched
+			, raSpillClean		= code_spillclean
+			, raFinal		= code_final
+			, raSRMs		= foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+
+
+		let statList =
+			if dump	then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+				else []
+
+		-- space leak avoidance
+		seqList statList `seq` return ()
+
+		return	( code_final
+			, statList
+			, graph_colored_lint)
+
+	 -- we couldn't find a coloring, time to spill something
+	 else do
+		-- if -fasm-lint is turned on then validate the graph
+		let graph_colored_lint	=
+			if dopt Opt_DoAsmLinting dflags
+				then Color.validateGraph (text "")
+					False 	-- don't require nodes to be colored
+					graph_colored
+				else graph_colored
+
+	 	-- spill the uncolored regs
+		(code_spilled, slotsFree', spillStats)
+			<- regSpill code_coalesced slotsFree rsSpill
+
+		-- recalculate liveness
+		let code_nat	= map stripLive code_spilled
+		code_relive	<- mapM regLiveness code_nat
+
+		-- record what happened in this stage for debugging
+		let stat	=
+			RegAllocStatsSpill
+			{ raGraph	= graph_colored_lint
+			, raCoalesced	= rmCoalesce
+			, raSpillStats	= spillStats
+			, raSpillCosts	= spillCosts
+			, raSpilled	= code_spilled }
+			    	
+		let statList =
+			if dump
+				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+				else []
+
+		-- space leak avoidance
+		seqList statList `seq` return ()
+
+		regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
+			statList
+			code_relive
+
+
+
+-- | Build a graph from the liveness and coalesce information in this code.
+
+buildGraph 
+	:: [LiveCmmTop]
+	-> UniqSM (Color.Graph Reg RegClass Reg)
+	
+buildGraph code
+ = do
+	-- Slurp out the conflicts and reg->reg moves from this code
+	let (conflictList, moveList) =
+		unzip $ map slurpConflicts code
+
+	-- Slurp out the spill/reload coalesces
+	let moveList2		= map slurpReloadCoalesce code
+
+ 	-- Add the reg-reg conflicts to the graph
+	let conflictBag		= unionManyBags conflictList
+	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
+
+	-- Add the coalescences edges to the graph.
+	let moveBag		= unionBags (unionManyBags moveList2) (unionManyBags moveList)
+	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
+			
+	return	graph_coalesce
+
+
+-- | Add some conflict edges to the graph.
+--	Conflicts between virtual and real regs are recorded as exclusions.
+--
+graphAddConflictSet 
+	:: UniqSet Reg
+	-> Color.Graph Reg RegClass Reg
+	-> Color.Graph Reg RegClass Reg
+	
+graphAddConflictSet set graph
+ = let	reals		= filterUFM isRealReg set
+ 	virtuals	= filterUFM (not . isRealReg) set
+ 
+	graph1	= Color.addConflicts virtuals regClass graph
+	graph2	= foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
+			graph1
+			[ (a, b) 
+				| a <- uniqSetToList virtuals
+				, b <- uniqSetToList reals]
+
+   in	graph2
+	
+
+-- | Add some coalesence edges to the graph
+--	Coalesences between virtual and real regs are recorded as preferences.
+--
+graphAddCoalesce 
+	:: (Reg, Reg) 
+	-> Color.Graph Reg RegClass Reg
+	-> Color.Graph Reg RegClass Reg
+	
+graphAddCoalesce (r1, r2) graph
+	| RealReg _ <- r1
+	= Color.addPreference (regWithClass r2) r1 graph
+	
+	| RealReg _ <- r2
+	= Color.addPreference (regWithClass r1) r2 graph
+	
+	| otherwise
+	= Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
+
+	where 	regWithClass r	= (r, regClass r)
+
+
+-- | Patch registers in code using the reg -> reg mapping in this graph.
+patchRegsFromGraph 
+	:: Color.Graph Reg RegClass Reg
+	-> LiveCmmTop -> LiveCmmTop
+
+patchRegsFromGraph graph code
+ = let
+ 	-- a function to lookup the hardreg for a virtual reg from the graph.
+ 	patchF reg
+		-- leave real regs alone.
+		| isRealReg reg
+		= reg
+
+		-- this virtual has a regular node in the graph.
+ 		| Just node	<- Color.lookupNode graph reg
+		= case Color.nodeColor node of
+			Just color	-> color
+			Nothing		-> reg
+			
+		-- no node in the graph for this virtual, bad news.
+		| otherwise
+		= pprPanic "patchRegsFromGraph: register mapping failed." 
+			(  text "There is no node in the graph for register " <> ppr reg
+			$$ ppr code
+			$$ Color.dotGraph (\_ -> text "white") trivColorable graph)
+
+   in	patchEraseLive patchF code
+   
+
+-----
+-- for when laziness just isn't what you wanted...
+--
+seqGraph :: Color.Graph Reg RegClass Reg -> ()
+seqGraph graph		= seqNodes (eltsUFM (Color.graphMap graph))
+
+seqNodes :: [Color.Node Reg RegClass Reg] -> ()
+seqNodes ns
+ = case ns of
+ 	[]		-> ()
+	(n : ns)	-> seqNode n `seq` seqNodes ns
+
+seqNode :: Color.Node Reg RegClass Reg -> ()
+seqNode node
+	=     seqReg      (Color.nodeId node)
+	`seq` seqRegClass (Color.nodeClass node)
+	`seq` seqMaybeReg (Color.nodeColor node)
+	`seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
+	`seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
+	`seq` (seqRegList (Color.nodePreference node))
+	`seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
+
+seqReg :: Reg -> ()
+seqReg reg
+ = case reg of
+ 	RealReg _	-> ()
+	VirtualRegI _	-> ()
+	VirtualRegHi _	-> ()
+	VirtualRegF _	-> ()
+	VirtualRegD _	-> ()
+
+seqRegClass :: RegClass -> ()
+seqRegClass c
+ = case c of
+ 	RcInteger	-> ()
+	RcFloat		-> ()
+	RcDouble	-> ()
+
+seqMaybeReg :: Maybe Reg -> ()
+seqMaybeReg mr
+ = case mr of
+ 	Nothing		-> ()
+	Just r		-> seqReg r
+
+seqRegList :: [Reg] -> ()
+seqRegList rs
+ = case rs of
+ 	[]		-> ()
+	(r : rs)	-> seqReg r `seq` seqRegList rs
+
+seqList :: [a] -> ()
+seqList ls
+ = case ls of
+ 	[]		-> ()
+	(r : rs)	-> r `seq` seqList rs
+
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
new file mode 100644
index 0000000000..3a377d20af
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -0,0 +1,230 @@
+
+{-# OPTIONS -fno-warn-missing-signatures #-}
+
+module RegAlloc.Graph.Spill (
+	regSpill,
+	SpillStats(..),
+	accSpillSL
+)
+
+where
+
+import RegLiveness
+import RegAllocInfo
+import MachRegs
+import MachInstrs
+import Cmm
+
+import State
+import Unique
+import UniqFM
+import UniqSet
+import UniqSupply
+import Outputable
+
+import Data.List
+import Data.Maybe
+
+
+-- | Spill all these virtual regs to memory
+--	TODO: 	see if we can split some of the live ranges instead of just globally
+--		spilling the virtual reg.
+--
+--	TODO:	On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
+--		when making spills. If an instr is using a spilled virtual we may be able to
+--		address the spill slot directly.
+--
+regSpill
+	:: [LiveCmmTop]			-- ^ the code
+	-> UniqSet Int			-- ^ available stack slots
+	-> UniqSet Reg			-- ^ the regs to spill
+	-> UniqSM
+		([LiveCmmTop]		-- code will spill instructions
+		, UniqSet Int		-- left over slots
+		, SpillStats )		-- stats about what happened during spilling
+
+regSpill code slotsFree regs
+
+	-- not enough slots to spill these regs
+	| sizeUniqSet slotsFree < sizeUniqSet regs
+	= pprPanic "regSpill: out of spill slots!"
+		(  text "   regs to spill = " <> ppr (sizeUniqSet regs)
+		$$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
+
+	| otherwise
+	= do
+		-- allocate a slot for each of the spilled regs
+		let slots	= take (sizeUniqSet regs) $ uniqSetToList slotsFree
+		let regSlotMap	= listToUFM
+				$ zip (uniqSetToList regs) slots
+
+		-- grab the unique supply from the monad
+		us	<- getUs
+
+		-- run the spiller on all the blocks
+		let (code', state')	=
+			runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
+				 (initSpillS us)
+
+		return	( code'
+			, minusUniqSet slotsFree (mkUniqSet slots)
+			, makeSpillStats state')
+
+
+regSpill_block regSlotMap (BasicBlock i instrs)
+ = do	instrss'	<- mapM (regSpill_instr regSlotMap) instrs
+ 	return	$ BasicBlock i (concat instrss')
+
+regSpill_instr _	li@(Instr _ Nothing)
+ = do	return [li]
+
+regSpill_instr regSlotMap
+	(Instr instr (Just _))
+ = do
+	-- work out which regs are read and written in this instr
+	let RU rlRead rlWritten	= regUsage instr
+
+	-- sometimes a register is listed as being read more than once,
+	--	nub this so we don't end up inserting two lots of spill code.
+	let rsRead_		= nub rlRead
+	let rsWritten_		= nub rlWritten
+
+	-- if a reg is modified, it appears in both lists, want to undo this..
+	let rsRead		= rsRead_    \\ rsWritten_
+	let rsWritten		= rsWritten_ \\ rsRead_
+	let rsModify		= intersect rsRead_ rsWritten_
+
+	-- work out if any of the regs being used are currently being spilled.
+	let rsSpillRead		= filter (\r -> elemUFM r regSlotMap) rsRead
+	let rsSpillWritten	= filter (\r -> elemUFM r regSlotMap) rsWritten
+	let rsSpillModify	= filter (\r -> elemUFM r regSlotMap) rsModify
+
+	-- rewrite the instr and work out spill code.
+	(instr1, prepost1)	<- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
+	(instr2, prepost2)	<- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
+	(instr3, prepost3)	<- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+
+	let (mPrefixes, mPostfixes)	= unzip (prepost1 ++ prepost2 ++ prepost3)
+	let prefixes			= concat mPrefixes
+	let postfixes			= concat mPostfixes
+
+	-- final code
+	let instrs'	=  map (\i -> Instr i Nothing) prefixes
+			++ [ Instr instr3 Nothing ]
+			++ map (\i -> Instr i Nothing) postfixes
+
+	return
+{-		$ pprTrace "* regSpill_instr spill"
+			(  text "instr  = " <> ppr instr
+			$$ text "read   = " <> ppr rsSpillRead
+			$$ text "write  = " <> ppr rsSpillWritten
+			$$ text "mod    = " <> ppr rsSpillModify
+			$$ text "-- out"
+			$$ (vcat $ map ppr instrs')
+			$$ text " ")
+-}
+		$ instrs'
+
+
+spillRead regSlotMap instr reg
+	| Just slot	<- lookupUFM regSlotMap reg
+	= do 	(instr', nReg)	<- patchInstr reg instr
+
+		modify $ \s -> s
+			{ stateSpillSL 	= addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
+
+	 	return	( instr'
+			, ( [RELOAD slot nReg]
+			  , []) )
+
+	| otherwise	= panic "RegSpill.spillRead: no slot defined for spilled reg"
+
+spillWrite regSlotMap instr reg
+	| Just slot	<- lookupUFM regSlotMap reg
+	= do 	(instr', nReg)	<- patchInstr reg instr
+
+		modify $ \s -> s
+			{ stateSpillSL 	= addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
+
+	 	return	( instr'
+			, ( []
+			  , [SPILL nReg slot]))
+
+	| otherwise	= panic "RegSpill.spillWrite: no slot defined for spilled reg"
+
+spillModify regSlotMap instr reg
+	| Just slot	<- lookupUFM regSlotMap reg
+	= do	(instr', nReg)	<- patchInstr reg instr
+
+		modify $ \s -> s
+			{ stateSpillSL 	= addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
+
+		return	( instr'
+			, ( [RELOAD slot nReg]
+			  , [SPILL nReg slot]))
+
+	| otherwise	= panic "RegSpill.spillModify: no slot defined for spilled reg"
+
+
+
+-- | rewrite uses of this virtual reg in an instr to use a different virtual reg
+patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
+patchInstr reg instr
+ = do	nUnique		<- newUnique
+ 	let nReg	= renameVirtualReg nUnique reg
+	let instr'	= patchReg1 reg nReg instr
+	return		(instr', nReg)
+
+patchReg1 :: Reg -> Reg -> Instr -> Instr
+patchReg1 old new instr
+ = let	patchF r
+		| r == old	= new
+		| otherwise	= r
+   in	patchRegs instr patchF
+
+
+------------------------------------------------------
+-- Spiller monad
+
+data SpillS
+	= SpillS
+	{ stateUS	:: UniqSupply
+	, stateSpillSL	:: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
+
+initSpillS uniqueSupply
+	= SpillS
+	{ stateUS	= uniqueSupply
+	, stateSpillSL	= emptyUFM }
+
+type SpillM a	= State SpillS a
+
+newUnique :: SpillM Unique
+newUnique
+ = do	us	<- gets stateUS
+ 	case splitUniqSupply us of
+	 (us1, us2)
+	  -> do let uniq = uniqFromSupply us1
+	  	modify $ \s -> s { stateUS = us2 }
+		return uniq
+
+accSpillSL (r1, s1, l1) (_, s2, l2)
+	= (r1, s1 + s2, l1 + l2)
+
+
+----------------------------------------------------
+-- Spiller stats
+
+data SpillStats
+	= SpillStats
+	{ spillStoreLoad	:: UniqFM (Reg, Int, Int) }
+
+makeSpillStats :: SpillS -> SpillStats
+makeSpillStats s
+	= SpillStats
+	{ spillStoreLoad	= stateSpillSL s }
+
+instance Outputable SpillStats where
+ ppr stats
+ 	= (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
+			$ eltsUFM (spillStoreLoad stats))
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
new file mode 100644
index 0000000000..ddb24614f5
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -0,0 +1,515 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
+-- | Clean out unneeded spill\/reload instrs
+--
+-- * Handling of join points
+--
+--   B1:                          B2:
+--    ...                          ...
+--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
+--       ... A ...                    ... B ...
+--       jump B3                      jump B3
+--
+--                B3: ... C ...
+--                    RELOAD SLOT(0), %r1
+--                    ...
+--
+-- the plan:
+--	So long as %r1 hasn't been written to in A, B or C then we don't need the
+--	reload in B3.
+--
+--	What we really care about here is that on the entry to B3, %r1 will always
+--	have the same value that is in SLOT(0) (ie, %r1 is _valid_)
+--
+--	This also works if the reloads in B1\/B2 were spills instead, because
+--	spilling %r1 to a slot makes that slot have the same value as %r1.
+--
+
+module RegAlloc.Graph.SpillClean (
+	cleanSpills
+)
+where
+
+import BlockId
+import RegLiveness
+import RegAllocInfo
+import MachRegs
+import MachInstrs
+import Cmm
+
+import UniqSet
+import UniqFM
+import Unique
+import State
+import Outputable
+import Util
+
+import Data.Maybe
+import Data.List        ( find, nub )
+
+--
+type Slot = Int
+
+
+-- | Clean out unneeded spill\/reloads from this top level thing.
+cleanSpills :: LiveCmmTop -> LiveCmmTop
+cleanSpills cmm
+	= evalState (cleanSpin 0 cmm) initCleanS
+
+-- | do one pass of cleaning
+cleanSpin :: Int -> LiveCmmTop -> CleanM LiveCmmTop
+
+{-
+cleanSpin spinCount code
+ = do	jumpValid	<- gets sJumpValid
+	pprTrace "cleanSpin"
+	 	(  int spinCount
+		$$ text "--- code"
+		$$ ppr code
+		$$ text "--- joins"
+		$$ ppr jumpValid)
+	 $ cleanSpin' spinCount code
+-}
+
+cleanSpin spinCount code
+ = do
+ 	-- init count of cleaned spills\/reloads
+	modify $ \s -> s
+		{ sCleanedSpillsAcc	= 0
+		, sCleanedReloadsAcc	= 0
+		, sReloadedBy		= emptyUFM }
+
+ 	code_forward	<- mapBlockTopM cleanBlockForward  code
+	code_backward	<- mapBlockTopM cleanBlockBackward code_forward
+
+	-- During the cleaning of each block we collected information about what regs
+	--	were valid across each jump. Based on this, work out whether it will be
+	--	safe to erase reloads after join points for the next pass.
+	collateJoinPoints
+
+	-- remember how many spills\/reloads we cleaned in this pass
+	spills		<- gets sCleanedSpillsAcc
+	reloads		<- gets sCleanedReloadsAcc
+	modify $ \s -> s
+		{ sCleanedCount	= (spills, reloads) : sCleanedCount s }
+
+	-- if nothing was cleaned in this pass or the last one
+	--	then we're done and it's time to bail out
+	cleanedCount	<- gets sCleanedCount
+	if take 2 cleanedCount == [(0, 0), (0, 0)]
+	   then return code
+
+	-- otherwise go around again
+	   else cleanSpin (spinCount + 1) code_backward
+
+
+-- | Clean one basic block
+cleanBlockForward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockForward (BasicBlock blockId instrs)
+ = do
+ 	-- see if we have a valid association for the entry to this block
+ 	jumpValid	<- gets sJumpValid
+ 	let assoc	= case lookupUFM jumpValid blockId of
+				Just assoc	-> assoc
+				Nothing		-> emptyAssoc
+
+ 	instrs_reload	<- cleanForward    blockId assoc [] instrs
+	return	$ BasicBlock blockId instrs_reload
+
+
+cleanBlockBackward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockBackward (BasicBlock blockId instrs)
+ = do	instrs_spill	<- cleanBackward  emptyUniqSet  [] instrs
+	return	$ BasicBlock blockId instrs_spill
+
+
+
+
+-- | Clean out unneeded reload instructions.
+--	Walking forwards across the code
+--	  On a reload, if we know a reg already has the same value as a slot
+--	  then we don't need to do the reload.
+--
+cleanForward
+	:: BlockId		-- ^ the block that we're currently in
+	-> Assoc Store	 	-- ^ two store locations are associated if they have the same value
+	-> [LiveInstr]		-- ^ acc
+	-> [LiveInstr] 		-- ^ instrs to clean (in backwards order)
+	-> CleanM [LiveInstr]	-- ^ cleaned instrs  (in forward   order)
+
+cleanForward _ _ acc []
+	= return acc
+
+-- write out live range joins via spill slots to just a spill and a reg-reg move
+--	hopefully the spill will be also be cleaned in the next pass
+--
+cleanForward blockId assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
+
+	| SPILL  reg1  slot1	<- i1
+	, RELOAD slot2 reg2	<- i2
+	, slot1 == slot2
+	= do
+		modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+		cleanForward blockId assoc acc
+			(Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
+
+
+cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
+	| Just (r1, r2)	<- isRegRegMove i1
+	= if r1 == r2
+		-- erase any left over nop reg reg moves while we're here
+		--	this will also catch any nop moves that the "write out live range joins" case above
+		--	happens to add
+		then cleanForward blockId assoc acc instrs
+
+		-- if r1 has the same value as some slots and we copy r1 to r2,
+		--	then r2 is now associated with those slots instead
+		else do	let assoc'	= addAssoc (SReg r1) (SReg r2)
+					$ delAssoc (SReg r2)
+					$ assoc
+
+			cleanForward blockId assoc' (li : acc) instrs
+
+
+cleanForward blockId assoc acc (li@(Instr instr _) : instrs)
+
+	-- update association due to the spill
+	| SPILL reg slot	<- instr
+	= let	assoc'	= addAssoc (SReg reg)  (SSlot slot)
+			$ delAssoc (SSlot slot)
+			$ assoc
+	  in	cleanForward blockId assoc' (li : acc) instrs
+
+	-- clean a reload instr
+	| RELOAD{}		<- instr
+	= do	(assoc', mli)	<- cleanReload blockId assoc li
+		case mli of
+		 Nothing	-> cleanForward blockId assoc' acc 		instrs
+		 Just li'	-> cleanForward blockId assoc' (li' : acc)	instrs
+
+	-- remember the association over a jump
+	| targets	<- jumpDests instr []
+	, not $ null targets
+	= do	mapM_ (accJumpValid assoc) targets
+		cleanForward blockId assoc (li : acc) instrs
+
+	-- writing to a reg changes its value.
+	| RU _ written	<- regUsage instr
+	= let assoc'	= foldr delAssoc assoc (map SReg $ nub written)
+	  in  cleanForward blockId assoc' (li : acc) instrs
+
+
+-- | Try and rewrite a reload instruction to something more pleasing
+--
+cleanReload :: BlockId -> Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr)
+cleanReload blockId assoc li@(Instr (RELOAD slot reg) _)
+
+	-- if the reg we're reloading already has the same value as the slot
+	--	then we can erase the instruction outright
+	| elemAssoc (SSlot slot) (SReg reg) assoc
+	= do 	modify 	$ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+	   	return	(assoc, Nothing)
+
+	-- if we can find another reg with the same value as this slot then
+	--	do a move instead of a reload.
+	| Just reg2	<- findRegOfSlot assoc slot
+	= do	modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+
+		let assoc'	= addAssoc (SReg reg) (SReg reg2)
+				$ delAssoc (SReg reg)
+				$ assoc
+
+		return	(assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing)
+
+	-- gotta keep this instr
+	| otherwise
+	= do	-- update the association
+		let assoc'	= addAssoc (SReg reg)  (SSlot slot)	-- doing the reload makes reg and slot the same value
+				$ delAssoc (SReg reg)			-- reg value changes on reload
+				$ assoc
+
+		-- remember that this block reloads from this slot
+		accBlockReloadsSlot blockId slot
+
+	    	return	(assoc', Just li)
+
+cleanReload _ _ _
+	= panic "RegSpillClean.cleanReload: unhandled instr"
+
+
+-- | Clean out unneeded spill instructions.
+--
+--	 If there were no reloads from a slot between a spill and the last one
+--	 then the slot was never read and we don't need the spill.
+--
+--	SPILL   r0 -> s1
+--	RELOAD  s1 -> r2
+--	SPILL   r3 -> s1	<--- don't need this spill
+--	SPILL   r4 -> s1
+--	RELOAD  s1 -> r5
+--
+--	Maintain a set of
+--		"slots which were spilled to but not reloaded from yet"
+--
+--	Walking backwards across the code:
+--	 a) On a reload from a slot, remove it from the set.
+--
+--	 a) On a spill from a slot
+--		If the slot is in set then we can erase the spill,
+--			because it won't be reloaded from until after the next spill.
+--
+--		otherwise
+--			keep the spill and add the slot to the set
+--
+-- TODO: This is mostly inter-block
+--	 we should really be updating the noReloads set as we cross jumps also.
+--
+cleanBackward
+	:: UniqSet Int 		-- ^ slots that have been spilled, but not reloaded from
+	-> [LiveInstr]		-- ^ acc
+	-> [LiveInstr]		-- ^ instrs to clean (in forwards order)
+	-> CleanM [LiveInstr]	-- ^ cleaned instrs  (in backwards order)
+
+
+cleanBackward noReloads acc lis
+ = do	reloadedBy	<- gets sReloadedBy
+ 	cleanBackward' reloadedBy noReloads acc lis
+
+cleanBackward' _ _      acc []
+	= return  acc
+
+cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
+
+	-- if nothing ever reloads from this slot then we don't need the spill
+	| SPILL _ slot	<- instr
+	, Nothing	<- lookupUFM reloadedBy (SSlot slot)
+	= do	modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+		cleanBackward noReloads acc instrs
+
+	| SPILL _ slot	<- instr
+	= if elementOfUniqSet slot noReloads
+
+	   -- we can erase this spill because the slot won't be read until after the next one
+	   then do
+		modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+	   	cleanBackward noReloads acc instrs
+
+	   else do
+		-- this slot is being spilled to, but we haven't seen any reloads yet.
+		let noReloads'	= addOneToUniqSet noReloads slot
+	   	cleanBackward noReloads' (li : acc) instrs
+
+	-- if we reload from a slot then it's no longer unused
+	| RELOAD slot _		<- instr
+	, noReloads'		<- delOneFromUniqSet noReloads slot
+	= cleanBackward noReloads' (li : acc) instrs
+
+	-- some other instruction
+	| otherwise
+	= cleanBackward noReloads (li : acc) instrs
+
+
+-- collateJoinPoints:
+--
+-- | combine the associations from all the inward control flow edges.
+--
+collateJoinPoints :: CleanM ()
+collateJoinPoints
+ = modify $ \s -> s
+ 	{ sJumpValid	= mapUFM intersects (sJumpValidAcc s)
+	, sJumpValidAcc	= emptyUFM }
+
+intersects :: [Assoc Store]	-> Assoc Store
+intersects []		= emptyAssoc
+intersects assocs	= foldl1' intersectAssoc assocs
+
+
+-- | See if we have a reg with the same value as this slot in the association table.
+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
+findRegOfSlot assoc slot
+	| close			<- closeAssoc (SSlot slot) assoc
+	, Just (SReg reg)	<- find isStoreReg $ uniqSetToList close
+	= Just reg
+
+	| otherwise
+	= Nothing
+
+
+---------------
+type CleanM = State CleanS
+data CleanS
+	= CleanS
+	{ -- regs which are valid at the start of each block.
+	  sJumpValid		:: UniqFM (Assoc Store)
+
+ 	  -- collecting up what regs were valid across each jump.
+	  --	in the next pass we can collate these and write the results
+	  --	to sJumpValid.
+	, sJumpValidAcc		:: UniqFM [Assoc Store]
+
+	  -- map of (slot -> blocks which reload from this slot)
+	  --	used to decide if whether slot spilled to will ever be
+	  --	reloaded from on this path.
+	, sReloadedBy		:: UniqFM [BlockId]
+
+	  -- spills\/reloads cleaned each pass (latest at front)
+	, sCleanedCount		:: [(Int, Int)]
+
+	  -- spills\/reloads that have been cleaned in this pass so far.
+	, sCleanedSpillsAcc	:: Int
+	, sCleanedReloadsAcc	:: Int }
+
+initCleanS :: CleanS
+initCleanS
+	= CleanS
+	{ sJumpValid		= emptyUFM
+	, sJumpValidAcc		= emptyUFM
+
+	, sReloadedBy		= emptyUFM
+
+	, sCleanedCount		= []
+
+	, sCleanedSpillsAcc	= 0
+	, sCleanedReloadsAcc	= 0 }
+
+
+-- | Remember the associations before a jump
+accJumpValid :: Assoc Store -> BlockId -> CleanM ()
+accJumpValid assocs target
+ = modify $ \s -> s {
+	sJumpValidAcc = addToUFM_C (++)
+				(sJumpValidAcc s)
+				target
+				[assocs] }
+
+
+accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
+accBlockReloadsSlot blockId slot
+ = modify $ \s -> s {
+ 	sReloadedBy = addToUFM_C (++)
+				(sReloadedBy s)
+				(SSlot slot)
+				[blockId] }
+
+
+--------------
+-- A store location can be a stack slot or a register
+--
+data Store
+	= SSlot Int
+	| SReg  Reg
+
+-- | Check if this is a reg store
+isStoreReg :: Store -> Bool
+isStoreReg ss
+ = case ss of
+ 	SSlot _	-> False
+	SReg  _	-> True
+
+-- spill cleaning is only done once all virtuals have been allocated to realRegs
+--
+instance Uniquable Store where
+    getUnique (SReg  r)
+	| RealReg i	<- r
+	= mkUnique 'R' i
+
+	| otherwise
+	= error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
+
+    getUnique (SSlot i)			= mkUnique 'S' i
+
+instance Outputable Store where
+	ppr (SSlot i)	= text "slot" <> int i
+	ppr (SReg  r)	= ppr r
+
+
+--------------
+-- Association graphs.
+--	In the spill cleaner, two store locations are associated if they are known
+--	to hold the same value.
+--
+type Assoc a	= UniqFM (UniqSet a)
+
+-- | an empty association
+emptyAssoc :: Assoc a
+emptyAssoc	= emptyUFM
+
+
+-- | add an association between these two things
+addAssoc :: Uniquable a
+	 => a -> a -> Assoc a -> Assoc a
+
+addAssoc a b m
+ = let	m1	= addToUFM_C unionUniqSets m  a (unitUniqSet b)
+ 	m2	= addToUFM_C unionUniqSets m1 b (unitUniqSet a)
+   in	m2
+
+
+-- | delete all associations to a node
+delAssoc :: (Outputable a, Uniquable a)
+ 	 => a -> Assoc a -> Assoc a
+
+delAssoc a m
+	| Just aSet	<- lookupUFM  m a
+	, m1		<- delFromUFM m a
+	= foldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
+
+	| otherwise	= m
+
+
+-- | delete a single association edge (a -> b)
+delAssoc1 :: Uniquable a
+	=> a -> a -> Assoc a -> Assoc a
+
+delAssoc1 a b m
+	| Just aSet	<- lookupUFM m a
+	= addToUFM m a (delOneFromUniqSet aSet b)
+
+	| otherwise	= m
+
+
+-- | check if these two things are associated
+elemAssoc :: (Outputable a, Uniquable a)
+	  => a -> a -> Assoc a -> Bool
+
+elemAssoc a b m
+	= elementOfUniqSet b (closeAssoc a m)
+
+-- | find the refl. trans. closure of the association from this point
+closeAssoc :: (Outputable a, Uniquable a)
+	=> a -> Assoc a -> UniqSet a
+
+closeAssoc a assoc
+ = 	closeAssoc' assoc emptyUniqSet (unitUniqSet a)
+ where
+	closeAssoc' assoc visited toVisit
+	 = case uniqSetToList toVisit of
+
+		-- nothing else to visit, we're done
+	 	[]	-> visited
+
+		(x:_)
+
+		 -- we've already seen this node
+		 |  elementOfUniqSet x visited
+		 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
+
+		 -- haven't seen this node before,
+		 --	remember to visit all its neighbors
+		 |  otherwise
+		 -> let neighbors
+		 	 = case lookupUFM assoc x of
+				Nothing		-> emptyUniqSet
+				Just set	-> set
+
+		   in closeAssoc' assoc
+			(addOneToUniqSet visited x)
+			(unionUniqSets   toVisit neighbors)
+
+-- | intersect
+intersectAssoc
+	:: Uniquable a
+	=> Assoc a -> Assoc a -> Assoc a
+
+intersectAssoc a b
+ 	= intersectUFM_C (intersectUniqSets) a b
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
new file mode 100644
index 0000000000..8ae87a0814
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -0,0 +1,249 @@
+
+module RegAlloc.Graph.SpillCost (
+	SpillCostRecord,
+	plusSpillCostRecord,
+	pprSpillCostRecord,
+
+	SpillCostInfo,
+	zeroSpillCostInfo,
+	plusSpillCostInfo,
+
+	slurpSpillCostInfo,
+	chooseSpill,
+
+	lifeMapFromSpillCostInfo
+)
+
+where
+
+import GraphBase
+import RegLiveness
+import RegAllocInfo
+import MachInstrs
+import MachRegs
+import BlockId
+import Cmm
+
+import UniqFM
+import UniqSet
+import Outputable
+import State
+
+import Data.List	(nub, minimumBy)
+import Data.Maybe
+import Control.Monad
+
+type SpillCostRecord
+ = 	( Reg	-- register name
+	, Int	-- number of writes to this reg
+	, Int	-- number of reads from this reg
+	, Int)	-- number of instrs this reg was live on entry to
+
+type SpillCostInfo
+	= UniqFM SpillCostRecord
+
+
+zeroSpillCostInfo :: SpillCostInfo
+zeroSpillCostInfo	= emptyUFM
+
+-- | Add two spillCostInfos
+plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
+plusSpillCostInfo sc1 sc2
+	= plusUFM_C plusSpillCostRecord sc1 sc2
+
+plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
+plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
+	| r1 == r2	= (r1, a1 + a2, b1 + b2, c1 + c2)
+	| otherwise	= error "RegSpillCost.plusRegInt: regs don't match"
+
+
+-- | Slurp out information used for determining spill costs
+--	for each vreg, the number of times it was written to, read from,
+--	and the number of instructions it was live on entry to (lifetime)
+--
+slurpSpillCostInfo
+	:: LiveCmmTop
+	-> SpillCostInfo
+
+slurpSpillCostInfo cmm
+	= execState (countCmm cmm) zeroSpillCostInfo
+ where
+	countCmm CmmData{}		= return ()
+	countCmm (CmmProc info _ _ (ListGraph blocks))
+		= mapM_ (countComp info) blocks
+
+	countComp info (BasicBlock _ blocks)
+		= mapM_ (countBlock info) blocks
+
+	-- lookup the regs that are live on entry to this block in
+	--	the info table from the CmmProc
+ 	countBlock info (BasicBlock blockId instrs)
+		| LiveInfo _ _ blockLive	<- info
+		, Just rsLiveEntry		<- lookupBlockEnv blockLive blockId
+		= countLIs rsLiveEntry instrs
+
+		| otherwise
+		= error "RegLiveness.slurpSpillCostInfo: bad block"
+
+	countLIs _      []
+		= return ()
+
+	-- skip over comment and delta pseudo instrs
+	countLIs rsLive (Instr instr Nothing : lis)
+		| COMMENT{}	<- instr
+		= countLIs rsLive lis
+
+		| DELTA{}	<- instr
+		= countLIs rsLive lis
+
+		| otherwise
+		= pprPanic "RegSpillCost.slurpSpillCostInfo"
+			(text "no liveness information on instruction " <> ppr instr)
+
+	countLIs rsLiveEntry (Instr instr (Just live) : lis)
+	 = do
+		-- increment the lifetime counts for regs live on entry to this instr
+		mapM_ incLifetime $ uniqSetToList rsLiveEntry
+
+		-- increment counts for what regs were read/written from
+		let (RU read written)	= regUsage instr
+		mapM_ incUses	$ filter (not . isRealReg) $ nub read
+		mapM_ incDefs 	$ filter (not . isRealReg) $ nub written
+
+		-- compute liveness for entry to next instruction.
+	 	let rsLiveAcross
+			= rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+	 	let rsLiveNext
+			= (rsLiveAcross `unionUniqSets` (liveBorn     live))
+				        `minusUniqSet` (liveDieWrite live)
+
+	 	countLIs rsLiveNext lis
+
+	incDefs     reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0)
+	incUses	    reg	= modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0)
+	incLifetime reg	= modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
+
+
+-- | Choose a node to spill from this graph
+
+chooseSpill
+	:: SpillCostInfo
+	-> Graph Reg RegClass Reg
+	-> Reg
+
+chooseSpill info graph
+ = let	cost	= spillCost_length info graph
+ 	node	= minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
+		$ eltsUFM $ graphMap graph
+
+   in	nodeId node
+
+
+
+-- | Chaitins spill cost function is:
+--
+--          cost =     sum         loadCost * freq (u)  +    sum        storeCost * freq (d)
+--                  u <- uses (v)                         d <- defs (v)
+--
+--	There are no loops in our code at the momemnt, so we can set the freq's to 1
+--	We divide this by the degree if t
+--
+--
+--  If we don't have live range splitting then Chaitins function performs badly if we have
+--	lots of nested live ranges and very few registers.
+--
+--		 v1 v2 v3
+--	def v1	 .
+--	use v1   .
+--	def v2   .  .
+--	def v3   .  .  .
+--	use v1   .  .  .
+--	use v3   .  .  .
+--	use v2   .  .
+--	use v1   .
+--
+--
+--           defs uses degree   cost
+--	v1:  1     3     3      1.5
+--	v2:  1     2     3      1.0
+--	v3:  1     1     3      0.666
+--
+--  	v3 has the lowest cost, but if we only have 2 hardregs and we insert spill code for v3
+--	then this isn't going to improve the colorability of the graph.
+--
+--  When compiling SHA1, which as very long basic blocks and some vregs with very long live ranges
+--	the allocator seems to try and spill from the inside out and eventually run out of stack slots.
+--
+--  Without live range splitting, its's better to spill from the outside in so set the cost of very
+--	long live ranges to zero
+--
+{-
+spillCost_chaitin
+	:: SpillCostInfo
+	-> Graph Reg RegClass Reg
+	-> Reg
+	-> Float
+
+spillCost_chaitin info graph reg
+	-- Spilling a live range that only lives for 1 instruction isn't going to help
+	--	us at all - and we definately want to avoid trying to re-spill previously
+	--	inserted spill code.
+	| lifetime <= 1		= 1/0
+
+	-- It's unlikely that we'll find a reg for a live range this long
+	--	better to spill it straight up and not risk trying to keep it around
+	--	and have to go through the build/color cycle again.
+	| lifetime > allocatableRegsInClass (regClass reg) * 10
+	= 0
+
+	-- otherwise revert to chaitin's regular cost function.
+	| otherwise	= fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg)
+	where (_, defs, uses, lifetime)
+		= fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+-}
+
+-- Just spill the longest live range.
+spillCost_length
+	:: SpillCostInfo
+	-> Graph Reg RegClass Reg
+	-> Reg
+	-> Float
+
+spillCost_length info _ reg
+	| lifetime <= 1		= 1/0
+	| otherwise		= 1 / fromIntegral lifetime
+	where (_, _, _, lifetime)
+		= fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+
+
+
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (Reg, Int)
+lifeMapFromSpillCostInfo info
+ 	= listToUFM
+	$ map (\(r, _, _, life)	-> (r, (r, life)))
+	$ eltsUFM info
+
+
+-- | Work out the degree (number of neighbors) of this node which have the same class.
+nodeDegree :: Graph Reg RegClass Reg -> Reg -> Int
+nodeDegree graph reg
+	| Just node	<- lookupUFM (graphMap graph) reg
+	, virtConflicts	<- length 	$ filter (\r -> regClass r == regClass reg)
+					$ uniqSetToList $ nodeConflicts node
+	= virtConflicts + sizeUniqSet (nodeExclusions node)
+
+	| otherwise
+	= 0
+
+
+-- | Show a spill cost record, including the degree from the graph and final calulated spill cos
+pprSpillCostRecord :: Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
+pprSpillCostRecord graph (reg, uses, defs, life)
+ 	=  hsep
+	[ ppr reg
+	, ppr uses
+	, ppr defs
+	, ppr life
+	, ppr $ nodeDegree graph reg
+	, text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg) :: Float) ]
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
new file mode 100644
index 0000000000..bf9622d0c8
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -0,0 +1,351 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
+-- Carries interesting info for debugging / profiling of the 
+--	graph coloring register allocator.
+--
+
+module RegAlloc.Graph.Stats (
+	RegAllocStats (..),
+	regDotColor,
+
+	pprStats,
+	pprStatsSpills,
+	pprStatsLifetimes,
+	pprStatsConflict,
+	pprStatsLifeConflict,
+
+	countSRMs, addSRM
+)
+
+where
+
+#include "nativeGen/NCG.h"
+
+import qualified GraphColor as Color
+import RegLiveness
+import RegAllocInfo
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillCost
+import MachRegs
+import MachInstrs
+import Cmm
+
+import Outputable
+import UniqFM
+import UniqSet
+import State
+
+import Data.List
+
+data RegAllocStats
+
+	-- initial graph
+	= RegAllocStatsStart
+	{ raLiveCmm	:: [LiveCmmTop]			  -- ^ initial code, with liveness
+	, raGraph	:: Color.Graph Reg RegClass Reg   -- ^ the initial, uncolored graph
+	, raSpillCosts	:: SpillCostInfo } 		  -- ^ information to help choose which regs to spill
+
+	-- a spill stage
+	| RegAllocStatsSpill
+	{ raGraph	:: Color.Graph Reg RegClass Reg	-- ^ the partially colored graph
+	, raCoalesced	:: UniqFM Reg			-- ^ the regs that were coaleced
+	, raSpillStats	:: SpillStats 			-- ^ spiller stats
+	, raSpillCosts	:: SpillCostInfo 		-- ^ number of instrs each reg lives for
+	, raSpilled	:: [LiveCmmTop] }		-- ^ code with spill instructions added
+
+	-- a successful coloring
+	| RegAllocStatsColored
+	{ raGraph	 :: Color.Graph Reg RegClass Reg -- ^ the uncolored graph
+	, raGraphColored :: Color.Graph Reg RegClass Reg -- ^ the coalesced and colored graph
+	, raCoalesced	:: UniqFM Reg			-- ^ the regs that were coaleced
+	, raPatched	:: [LiveCmmTop] 		-- ^ code with vregs replaced by hregs
+	, raSpillClean  :: [LiveCmmTop]			-- ^ code with unneeded spill\/reloads cleaned out
+	, raFinal	:: [NatCmmTop] 			-- ^ final code
+	, raSRMs	:: (Int, Int, Int) }		-- ^ spill\/reload\/reg-reg moves present in this code
+
+instance Outputable RegAllocStats where
+
+ ppr (s@RegAllocStatsStart{})
+ 	=  text "#  Start"
+	$$ text "#  Native code with liveness information."
+	$$ ppr (raLiveCmm s)
+	$$ text ""
+	$$ text "#  Initial register conflict graph."
+	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+
+
+ ppr (s@RegAllocStatsSpill{})
+ 	=  text "#  Spill"
+
+	$$ text "#  Register conflict graph."
+	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+	$$ text ""
+
+	$$ (if (not $ isNullUFM $ raCoalesced s)
+		then 	text "#  Registers coalesced."
+			$$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+			$$ text ""
+		else empty)
+
+	$$ text "#  Spill costs.  reg uses defs lifetime degree cost"
+	$$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
+	$$ text ""
+
+	$$ text "#  Spills inserted."
+	$$ ppr (raSpillStats s)
+	$$ text ""
+
+	$$ text "#  Code with spills inserted."
+	$$ (ppr (raSpilled s))
+
+
+ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
+ 	=  text "#  Colored"
+
+	$$ text "#  Register conflict graph (initial)."
+	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+	$$ text ""
+
+	$$ text "#  Register conflict graph (colored)."
+	$$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
+	$$ text ""
+
+	$$ (if (not $ isNullUFM $ raCoalesced s)
+		then 	text "#  Registers coalesced."
+			$$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+			$$ text ""
+		else empty)
+
+	$$ text "#  Native code after register allocation."
+	$$ ppr (raPatched s)
+	$$ text ""
+
+	$$ text "#  Clean out unneeded spill/reloads."
+	$$ ppr (raSpillClean s)
+	$$ text ""
+
+	$$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
+	$$ ppr (raFinal s)
+	$$ text ""
+	$$  text "#  Score:"
+	$$ (text "#          spills  inserted: " <> int spills)
+	$$ (text "#          reloads inserted: " <> int reloads)
+	$$ (text "#   reg-reg moves remaining: " <> int moves)
+	$$ text ""
+
+-- | Do all the different analysis on this list of RegAllocStats
+pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
+pprStats stats graph
+ = let 	outSpills	= pprStatsSpills    stats
+	outLife		= pprStatsLifetimes stats
+	outConflict	= pprStatsConflict  stats
+	outScatter	= pprStatsLifeConflict stats graph
+
+  in	vcat [outSpills, outLife, outConflict, outScatter]
+
+
+-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
+pprStatsSpills
+	:: [RegAllocStats] -> SDoc
+
+pprStatsSpills stats
+ = let
+	finals	= [ s	| s@RegAllocStatsColored{} <- stats]
+
+	-- sum up how many stores\/loads\/reg-reg-moves were left in the code
+	total	= foldl' addSRM (0, 0, 0)
+		$ map raSRMs finals
+
+    in	(  text "-- spills-added-total"
+	$$ text "--    (stores, loads, reg_reg_moves_remaining)"
+	$$ ppr total
+	$$ text "")
+
+
+-- | Dump a table of how long vregs tend to live for in the initial code.
+pprStatsLifetimes
+	:: [RegAllocStats] -> SDoc
+
+pprStatsLifetimes stats
+ = let	info		= foldl' plusSpillCostInfo zeroSpillCostInfo
+ 				[ raSpillCosts s
+					| s@RegAllocStatsStart{} <- stats ]
+
+	lifeBins	= binLifetimeCount $ lifeMapFromSpillCostInfo info
+
+   in	(  text "-- vreg-population-lifetimes"
+	$$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+	$$ (vcat $ map ppr $ eltsUFM lifeBins)
+	$$ text "\n")
+
+binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
+binLifetimeCount fm
+ = let	lifes	= map (\l -> (l, (l, 1)))
+ 		$ map snd
+		$ eltsUFM fm
+
+   in	addListToUFM_C
+		(\(l1, c1) (_, c2) -> (l1, c1 + c2))
+		emptyUFM
+		lifes
+
+
+-- | Dump a table of how many conflicts vregs tend to have in the initial code.
+pprStatsConflict
+	:: [RegAllocStats] -> SDoc
+
+pprStatsConflict stats
+ = let	confMap	= foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
+			emptyUFM
+		$ map Color.slurpNodeConflictCount
+			[ raGraph s | s@RegAllocStatsStart{} <- stats ]
+
+   in	(  text "-- vreg-conflicts"
+	$$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
+	$$ (vcat $ map ppr $ eltsUFM confMap)
+	$$ text "\n")
+
+
+-- | For every vreg, dump it's how many conflicts it has and its lifetime
+--	good for making a scatter plot.
+pprStatsLifeConflict
+	:: [RegAllocStats]
+	-> Color.Graph Reg RegClass Reg 	-- ^ global register conflict graph
+	-> SDoc
+
+pprStatsLifeConflict stats graph
+ = let	lifeMap	= lifeMapFromSpillCostInfo
+ 		$ foldl' plusSpillCostInfo zeroSpillCostInfo
+		$ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
+
+ 	scatter	= map	(\r ->  let lifetime	= case lookupUFM lifeMap r of
+							Just (_, l)	-> l
+							Nothing		-> 0
+				    Just node	= Color.lookupNode graph r
+				in parens $ hcat $ punctuate (text ", ")
+					[ doubleQuotes $ ppr $ Color.nodeId node
+					, ppr $ sizeUniqSet (Color.nodeConflicts node)
+					, ppr $ lifetime ])
+		$ map Color.nodeId
+		$ eltsUFM
+		$ Color.graphMap graph
+
+   in 	(  text "-- vreg-conflict-lifetime"
+	$$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
+	$$ (vcat scatter)
+	$$ text "\n")
+
+
+-- | Count spill/reload/reg-reg moves.
+--	Lets us see how well the register allocator has done.
+--
+countSRMs :: LiveCmmTop -> (Int, Int, Int)
+countSRMs cmm
+	= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+
+countSRM_block (BasicBlock i instrs)
+ = do	instrs'	<- mapM countSRM_instr instrs
+ 	return	$ BasicBlock i instrs'
+
+countSRM_instr li@(Instr instr _)
+	| SPILL _ _	<- instr
+	= do	modify 	$ \(s, r, m)	-> (s + 1, r, m)
+		return li
+
+	| RELOAD _ _	<- instr
+	= do	modify	$ \(s, r, m)	-> (s, r + 1, m)
+		return li
+
+	| Just _		<- isRegRegMove instr
+	= do	modify	$ \(s, r, m)	-> (s, r, m + 1)
+		return li
+
+	| otherwise
+	=	return li
+
+-- sigh..
+addSRM (s1, r1, m1) (s2, r2, m2)
+	= (s1+s2, r1+r2, m1+m2)
+
+-----
+-- Register colors for drawing conflict graphs
+--	Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
+
+
+-- reg colors for x86
+#if i386_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let	Just	str	= lookupUFM regColors reg
+   in	text str
+
+regColors
+ = listToUFM
+ $  	[ (eax,	"#00ff00")
+	, (ebx,	"#0000ff")
+	, (ecx,	"#00ffff")
+	, (edx,	"#0080ff")
+
+	, (fake0, "#ff00ff")
+	, (fake1, "#ff00aa")
+	, (fake2, "#aa00ff")
+	, (fake3, "#aa00aa")
+	, (fake4, "#ff0055")
+	, (fake5, "#5500ff") ]
+
+
+-- reg colors for x86_64
+#elif x86_64_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let	Just	str	= lookupUFM regColors reg
+   in	text str
+
+regColors
+ = listToUFM
+ $	[ (rax, "#00ff00"), (eax, "#00ff00")
+	, (rbx,	"#0000ff"), (ebx, "#0000ff")
+	, (rcx,	"#00ffff"), (ecx, "#00ffff")
+	, (rdx,	"#0080ff"), (edx, "#00ffff")
+	, (r8,  "#00ff80")
+	, (r9,  "#008080")
+	, (r10, "#0040ff")
+	, (r11, "#00ff40")
+	, (r12, "#008040")
+	, (r13, "#004080")
+	, (r14, "#004040")
+	, (r15, "#002080") ]
+
+	++ zip (map RealReg [16..31]) (repeat "red")
+
+
+-- reg colors for ppc
+#elif powerpc_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = case regClass reg of
+ 	RcInteger	-> text "blue"
+	RcFloat		-> text "red"
+	RcDouble	-> text "green"
+
+#elif sparc_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = case regClass reg of
+ 	RcInteger	-> text "blue"
+	RcFloat		-> text "red"
+	RcDouble	-> text "green"
+#else
+#error ToDo: regDotColor
+#endif
+
+
+{-
+toX11Color (r, g, b)
+ = let	rs	= padL 2 '0' (showHex r "")
+ 	gs	= padL 2 '0' (showHex r "")
+	bs	= padL 2 '0' (showHex r "")
+
+	padL n c s
+		= replicate (n - length s) c ++ s
+  in	"#" ++ rs ++ gs ++ bs
+-}