NCG: Split up the native code generator into arch specific modules

  - nativeGen/Instruction defines a type class for a generic
    instruction set. Each of the instruction sets we have, 
    X86, PPC and SPARC are instances of it.
  
  - The register alloctors use this type class when they need
    info about a certain register or instruction, such as
    regUsage, mkSpillInstr, mkJumpInstr, patchRegs..
  
  - nativeGen/Platform defines some data types enumerating
    the architectures and operating systems supported by the 
    native code generator.
  
  - DynFlags now keeps track of the current build platform, and 
    the PositionIndependentCode module uses this to decide what
    to do instead of relying of #ifdefs.
  
  - It's not totally retargetable yet. Some info info about the
    build target is still hardwired, but I've tried to contain
    most of it to a single module, TargetRegs.
  
  - Moved the SPILL and RELOAD instructions into LiveInstr.
  
  - Reg and RegClass now have their own modules, and are shared
    across all architectures.

7 files changed, 395 insertions, 198 deletions

diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 18e4b0edd1..8521e92601 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -8,11 +8,11 @@ module RegAlloc.Graph.Coalesce (
 
 where
 
-import Cmm
-import Regs
 import RegAlloc.Liveness
-import RegAllocInfo
+import Instruction
+import Reg
 
+import Cmm
 import Bag
 import UniqFM
 import UniqSet
@@ -26,7 +26,11 @@ import Data.List
 --	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 
+	:: Instruction instr
+	=> [LiveCmmTop instr] 
+	-> UniqSM [LiveCmmTop instr]
+
 regCoalesce code
  = do	
  	let joins	= foldl' unionBags emptyBag
@@ -57,7 +61,11 @@ sinkReg fm r
 --	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 
+	:: Instruction instr
+	=> LiveCmmTop instr 
+	-> Bag (Reg, Reg)
+
 slurpJoinMovs live
 	= slurpCmm emptyBag live
  where	
@@ -68,7 +76,7 @@ slurpJoinMovs live
                 
         slurpLI    rs (Instr _	Nothing)	         = rs
 	slurpLI    rs (Instr instr (Just live))
-	 	| Just (r1, r2)	<- isRegRegMove instr
+	 	| Just (r1, r2)	<- takeRegRegMoveInstr instr
 		, elementOfUniqSet r1 $ liveDieRead live
 		, elementOfUniqSet r2 $ liveBorn live
 
@@ -80,4 +88,7 @@ slurpJoinMovs live
 		| otherwise
 		= rs
 	
+	slurpLI	   rs SPILL{} 	= rs
+	slurpLI    rs RELOAD{}	= rs
+		
 	
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index fe99aba120..2e584617e9 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -5,8 +5,7 @@
 --
 
 module RegAlloc.Graph.Main ( 
-	regAlloc,
-	regDotColor
+	regAlloc
 ) 
 
 where
@@ -17,9 +16,12 @@ import RegAlloc.Graph.Spill
 import RegAlloc.Graph.SpillClean
 import RegAlloc.Graph.SpillCost
 import RegAlloc.Graph.Stats
-import Regs
-import Instrs
-import PprMach
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import TargetReg
+import RegClass
+import Reg
+
 
 import UniqSupply
 import UniqSet
@@ -43,18 +45,26 @@ maxSpinCount	= 10
 -- | The top level of the graph coloring register allocator.
 --	
 regAlloc
-	:: DynFlags
+	:: (Outputable instr, Instruction instr)
+	=> 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] )
+	-> [LiveCmmTop instr]		-- ^ code annotated with liveness information.
+	-> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
            -- ^ code with registers allocated and stats for each stage of
            -- allocation
 		
 regAlloc dflags regsFree slotsFree code
  = do
+	-- TODO: the regClass function is currently hard coded to the default target
+	--	 architecture. Would prefer to determine this from dflags.
+	--	 There are other uses of targetRegClass later in this module.
+	let triv = trivColorable targetRegClass
+
  	(code_final, debug_codeGraphs, _)
-		<- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
+		<- regAlloc_spin dflags 0 
+			triv
+			regsFree slotsFree [] code
 	
 	return	( code_final
 		, reverse debug_codeGraphs )
@@ -74,7 +84,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
 	 $ 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)
+	 	$$ text "regsFree    = " <> (hcat	$ punctuate space $ map ppr
 						$ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
 		$$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
 
@@ -139,12 +149,12 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
 		-- clean out unneeded SPILL/RELOADs
 		let code_spillclean	= map cleanSpills code_patched
 
-		-- strip off liveness information
-		let code_nat		= map stripLive code_spillclean
+		-- strip off liveness information, 
+		--	and rewrite SPILL/RELOAD pseudos into real instructions along the way
+		let code_final		= map stripLive code_spillclean
 
-		-- rewrite SPILL/RELOAD pseudos into real instructions
-		let spillNatTop		= mapGenBlockTop spillNatBlock
-		let code_final		= map spillNatTop code_nat
+--		let spillNatTop		= mapGenBlockTop spillNatBlock
+--		let code_final		= map spillNatTop code_nat
 		
 		-- record what happened in this stage for debugging
 		let stat		=
@@ -213,7 +223,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
 -- | Build a graph from the liveness and coalesce information in this code.
 
 buildGraph 
-	:: [LiveCmmTop]
+	:: Instruction instr
+	=> [LiveCmmTop instr]
 	-> UniqSM (Color.Graph Reg RegClass Reg)
 	
 buildGraph code
@@ -248,8 +259,8 @@ 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	= Color.addConflicts virtuals targetRegClass graph
+	graph2	= foldr (\(r1, r2) -> Color.addExclusion r1 targetRegClass r2)
 			graph1
 			[ (a, b) 
 				| a <- uniqSetToList virtuals
@@ -276,13 +287,14 @@ graphAddCoalesce (r1, r2) graph
 	| otherwise
 	= Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 
-	where 	regWithClass r	= (r, regClass r)
+	where 	regWithClass r	= (r, targetRegClass r)
 
 
 -- | Patch registers in code using the reg -> reg mapping in this graph.
 patchRegsFromGraph 
-	:: Color.Graph Reg RegClass Reg
-	-> LiveCmmTop -> LiveCmmTop
+	:: (Outputable instr, Instruction instr)
+	=> Color.Graph Reg RegClass Reg
+	-> LiveCmmTop instr -> LiveCmmTop instr
 
 patchRegsFromGraph graph code
  = let
@@ -303,7 +315,7 @@ patchRegsFromGraph graph code
 		= 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)
+			$$ Color.dotGraph (\_ -> text "white") (trivColorable targetRegClass) graph)
 
    in	patchEraseLive patchF code
    
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index b5a645188f..e6e5622a02 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -10,9 +10,8 @@ module RegAlloc.Graph.Spill (
 where
 
 import RegAlloc.Liveness
-import RegAllocInfo
-import Regs
-import Instrs
+import Instruction
+import Reg
 import Cmm
 
 import State
@@ -35,11 +34,12 @@ import Data.Maybe
 --		address the spill slot directly.
 --
 regSpill
-	:: [LiveCmmTop]			-- ^ the code
+	:: Instruction instr
+	=> [LiveCmmTop instr]		-- ^ the code
 	-> UniqSet Int			-- ^ available stack slots
 	-> UniqSet Reg			-- ^ the regs to spill
 	-> UniqSM
-		([LiveCmmTop]		-- code will spill instructions
+		([LiveCmmTop instr]	-- code will spill instructions
 		, UniqSet Int		-- left over slots
 		, SpillStats )		-- stats about what happened during spilling
 
@@ -75,6 +75,20 @@ regSpill_block regSlotMap (BasicBlock i instrs)
  = do	instrss'	<- mapM (regSpill_instr regSlotMap) instrs
  	return	$ BasicBlock i (concat instrss')
 
+
+regSpill_instr
+	:: Instruction instr
+	=> UniqFM Int 
+	-> LiveInstr instr -> SpillM [LiveInstr instr]
+
+-- | The thing we're spilling shouldn't already have spill or reloads in it
+regSpill_instr	_ SPILL{}
+	= panic "regSpill_instr: unexpected SPILL"
+
+regSpill_instr	_ RELOAD{}
+	= panic "regSpill_instr: unexpected RELOAD"
+
+
 regSpill_instr _	li@(Instr _ Nothing)
  = do	return [li]
 
@@ -82,7 +96,7 @@ regSpill_instr regSlotMap
 	(Instr instr (Just _))
  = do
 	-- work out which regs are read and written in this instr
-	let RU rlRead rlWritten	= regUsage instr
+	let RU rlRead rlWritten	= regUsageOfInstr 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.
@@ -109,9 +123,9 @@ regSpill_instr regSlotMap
 	let postfixes			= concat mPostfixes
 
 	-- final code
-	let instrs'	=  map (\i -> Instr i Nothing) prefixes
-			++ [ Instr instr3 Nothing ]
-			++ map (\i -> Instr i Nothing) postfixes
+	let instrs'	=  prefixes
+			++ [Instr instr3 Nothing]
+			++ postfixes
 
 	return
 {-		$ pprTrace "* regSpill_instr spill"
@@ -139,6 +153,7 @@ spillRead regSlotMap instr reg
 
 	| 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
@@ -152,6 +167,7 @@ spillWrite regSlotMap instr reg
 
 	| 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
@@ -168,19 +184,25 @@ spillModify regSlotMap instr reg
 
 
 -- | rewrite uses of this virtual reg in an instr to use a different virtual reg
-patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
+patchInstr 
+	:: Instruction instr
+	=> 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 
+	:: Instruction instr
+	=> Reg -> Reg -> instr -> instr
+
 patchReg1 old new instr
  = let	patchF r
 		| r == old	= new
 		| otherwise	= r
-   in	patchRegs instr patchF
+   in	patchRegsOfInstr instr patchF
 
 
 ------------------------------------------------------
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index b68648bdaf..4f129c468a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -29,13 +29,12 @@ module RegAlloc.Graph.SpillClean (
 )
 where
 
-import BlockId
 import RegAlloc.Liveness
-import RegAllocInfo
-import Regs
-import Instrs
-import Cmm
+import Instruction
+import Reg
 
+import BlockId
+import Cmm
 import UniqSet
 import UniqFM
 import Unique
@@ -51,12 +50,19 @@ type Slot = Int
 
 
 -- | Clean out unneeded spill\/reloads from this top level thing.
-cleanSpills :: LiveCmmTop -> LiveCmmTop
+cleanSpills 
+	:: Instruction instr
+	=> LiveCmmTop instr -> LiveCmmTop instr
+
 cleanSpills cmm
 	= evalState (cleanSpin 0 cmm) initCleanS
 
 -- | do one pass of cleaning
-cleanSpin :: Int -> LiveCmmTop -> CleanM LiveCmmTop
+cleanSpin 
+	:: Instruction instr
+	=> Int 
+	-> LiveCmmTop instr 
+	-> CleanM (LiveCmmTop instr)
 
 {-
 cleanSpin spinCount code
@@ -103,7 +109,11 @@ cleanSpin spinCount code
 
 
 -- | Clean one basic block
-cleanBlockForward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockForward 
+	:: Instruction instr
+	=> LiveBasicBlock instr 
+	-> CleanM (LiveBasicBlock instr)
+
 cleanBlockForward (BasicBlock blockId instrs)
  = do
  	-- see if we have a valid association for the entry to this block
@@ -116,7 +126,11 @@ cleanBlockForward (BasicBlock blockId instrs)
 	return	$ BasicBlock blockId instrs_reload
 
 
-cleanBlockBackward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockBackward 
+	:: Instruction instr
+	=> LiveBasicBlock instr 
+	-> CleanM (LiveBasicBlock instr)
+
 cleanBlockBackward (BasicBlock blockId instrs)
  = do	instrs_spill	<- cleanBackward  emptyUniqSet  [] instrs
 	return	$ BasicBlock blockId instrs_spill
@@ -130,11 +144,12 @@ cleanBlockBackward (BasicBlock blockId instrs)
 --	  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)
+	:: Instruction instr
+	=> BlockId			-- ^ the block that we're currently in
+	-> Assoc Store	 		-- ^ two store locations are associated if they have the same value
+	-> [LiveInstr instr]		-- ^ acc
+	-> [LiveInstr instr] 		-- ^ instrs to clean (in backwards order)
+	-> CleanM [LiveInstr instr]	-- ^ cleaned instrs  (in forward   order)
 
 cleanForward _ _ acc []
 	= return acc
@@ -142,19 +157,19 @@ cleanForward _ _ 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)
+cleanForward blockId assoc acc (li1 : li2 : instrs)
 
-	| SPILL  reg1  slot1	<- i1
-	, RELOAD slot2 reg2	<- i2
+	| SPILL  reg1  slot1	<- li1
+	, RELOAD slot2 reg2	<- li2
 	, slot1 == slot2
 	= do
 		modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
 		cleanForward blockId assoc acc
-			(Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
+			(li1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
 
 
 cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
-	| Just (r1, r2)	<- isRegRegMove i1
+	| Just (r1, r2)	<- takeRegRegMoveInstr 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
@@ -170,38 +185,50 @@ cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
 			cleanForward blockId assoc' (li : acc) instrs
 
 
-cleanForward blockId assoc acc (li@(Instr instr _) : instrs)
+cleanForward blockId assoc acc (li : instrs)
 
 	-- update association due to the spill
-	| SPILL reg slot	<- instr
+	| SPILL reg slot	<- li
 	= let	assoc'	= addAssoc (SReg reg)  (SSlot slot)
 			$ delAssoc (SSlot slot)
 			$ assoc
 	  in	cleanForward blockId assoc' (li : acc) instrs
 
 	-- clean a reload instr
-	| RELOAD{}		<- instr
+	| RELOAD{}		<- li
 	= 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 []
+	| Instr instr _ 	<- li
+	, targets		<- jumpDestsOfInstr 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
+	| Instr instr _		<- li
+	, RU _ written		<- regUsageOfInstr instr
 	= let assoc'	= foldr delAssoc assoc (map SReg $ nub written)
 	  in  cleanForward blockId assoc' (li : acc) instrs
 
+-- bogus, to stop pattern match warning
+cleanForward _ _ _ _ 
+	= panic "RegAlloc.Graph.SpillClean.cleanForward: no match"
+
 
 -- | 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) _)
+cleanReload 
+	:: Instruction instr
+	=> BlockId 
+	-> Assoc Store 
+	-> LiveInstr instr
+	-> CleanM (Assoc Store, Maybe (LiveInstr instr))
+
+cleanReload blockId assoc li@(RELOAD slot reg)
 
 	-- if the reg we're reloading already has the same value as the slot
 	--	then we can erase the instruction outright
@@ -264,10 +291,10 @@ cleanReload _ _ _
 --	 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)
+	:: UniqSet Int 			-- ^ slots that have been spilled, but not reloaded from
+	-> [LiveInstr instr]		-- ^ acc
+	-> [LiveInstr instr]		-- ^ instrs to clean (in forwards order)
+	-> CleanM [LiveInstr instr]	-- ^ cleaned instrs  (in backwards order)
 
 
 cleanBackward noReloads acc lis
@@ -277,15 +304,15 @@ cleanBackward noReloads acc lis
 cleanBackward' _ _      acc []
 	= return  acc
 
-cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
+cleanBackward' reloadedBy noReloads acc (li : instrs)
 
 	-- if nothing ever reloads from this slot then we don't need the spill
-	| SPILL _ slot	<- instr
+	| SPILL _ slot	<- li
 	, Nothing	<- lookupUFM reloadedBy (SSlot slot)
 	= do	modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
 		cleanBackward noReloads acc instrs
 
-	| SPILL _ slot	<- instr
+	| SPILL _ slot	<- li
 	= if elementOfUniqSet slot noReloads
 
 	   -- we can erase this spill because the slot won't be read until after the next one
@@ -299,7 +326,7 @@ cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
 	   	cleanBackward noReloads' (li : acc) instrs
 
 	-- if we reload from a slot then it's no longer unused
-	| RELOAD slot _		<- instr
+	| RELOAD slot _		<- li
 	, noReloads'		<- delOneFromUniqSet noReloads slot
 	= cleanBackward noReloads' (li : acc) instrs
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 1d37cf71d6..d4dd75a4b7 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -16,14 +16,16 @@ module RegAlloc.Graph.SpillCost (
 
 where
 
-import GraphBase
 import RegAlloc.Liveness
-import RegAllocInfo
-import Instrs
-import Regs
+import Instruction
+import RegClass
+import Reg
+
+import GraphBase
+
+
 import BlockId
 import Cmm
-
 import UniqFM
 import UniqSet
 import Outputable
@@ -62,7 +64,8 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
 --	and the number of instructions it was live on entry to (lifetime)
 --
 slurpSpillCostInfo
-	:: LiveCmmTop
+	:: (Outputable instr, Instruction instr)
+	=> LiveCmmTop instr
 	-> SpillCostInfo
 
 slurpSpillCostInfo cmm
@@ -89,11 +92,14 @@ slurpSpillCostInfo cmm
 		= return ()
 
 	-- skip over comment and delta pseudo instrs
-	countLIs rsLive (Instr instr Nothing : lis)
-		| COMMENT{}	<- instr
+	countLIs rsLive (SPILL{} : lis)
+		= countLIs rsLive lis
+		
+	countLIs rsLive (RELOAD{} : lis)
 		= countLIs rsLive lis
 
-		| DELTA{}	<- instr
+	countLIs rsLive (Instr instr Nothing : lis)
+		| isMetaInstr instr
 		= countLIs rsLive lis
 
 		| otherwise
@@ -106,7 +112,7 @@ slurpSpillCostInfo cmm
 		mapM_ incLifetime $ uniqSetToList rsLiveEntry
 
 		-- increment counts for what regs were read/written from
-		let (RU read written)	= regUsage instr
+		let (RU read written)	= regUsageOfInstr instr
 		mapM_ incUses	$ filter (not . isRealReg) $ nub read
 		mapM_ incDefs 	$ filter (not . isRealReg) $ nub written
 
@@ -226,8 +232,11 @@ lifeMapFromSpillCostInfo 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
+nodeDegree 
+	:: (Reg -> RegClass)
+	-> Graph Reg RegClass Reg -> Reg -> Int
+
+nodeDegree regClass graph reg
 	| Just node	<- lookupUFM (graphMap graph) reg
 	, virtConflicts	<- length 	$ filter (\r -> regClass r == regClass reg)
 					$ uniqSetToList $ nodeConflicts node
@@ -238,12 +247,17 @@ nodeDegree graph reg
 
 
 -- | 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)
+pprSpillCostRecord 
+	:: (Reg -> RegClass)
+	-> (Reg -> SDoc)
+	-> Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
+
+pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
  	=  hsep
-	[ ppr reg
+	[ pprReg reg
 	, ppr uses
 	, ppr defs
 	, ppr life
-	, ppr $ nodeDegree graph reg
-	, text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg) :: Float) ]
+	, ppr $ nodeDegree regClass graph reg
+	, text $ show $ (fromIntegral (uses + defs) 
+			/ fromIntegral (nodeDegree regClass graph reg) :: Float) ]
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 8082f9e975..5e3dd3265b 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -5,7 +5,6 @@
 
 module RegAlloc.Graph.Stats (
 	RegAllocStats (..),
-	regDotColor,
 
 	pprStats,
 	pprStatsSpills,
@@ -22,13 +21,13 @@ where
 
 import qualified GraphColor as Color
 import RegAlloc.Liveness
-import RegAllocInfo
 import RegAlloc.Graph.Spill
 import RegAlloc.Graph.SpillCost
-import Regs
-import Instrs
-import Cmm
+import Instruction
+import RegClass
+import Reg
 
+import Cmm
 import Outputable
 import UniqFM
 import UniqSet
@@ -36,11 +35,11 @@ import State
 
 import Data.List
 
-data RegAllocStats
+data RegAllocStats instr
 
 	-- initial graph
 	= RegAllocStatsStart
-	{ raLiveCmm	:: [LiveCmmTop]			  -- ^ initial code, with liveness
+	{ raLiveCmm	:: [LiveCmmTop instr]		  -- ^ initial code, with liveness
 	, raGraph	:: Color.Graph Reg RegClass Reg   -- ^ the initial, uncolored graph
 	, raSpillCosts	:: SpillCostInfo } 		  -- ^ information to help choose which regs to spill
 
@@ -50,35 +49,35 @@ data RegAllocStats
 	, 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
+	, raSpilled	:: [LiveCmmTop instr] }		-- ^ 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
+	, raPatched	:: [LiveCmmTop instr] 		-- ^ code with vregs replaced by hregs
+	, raSpillClean  :: [LiveCmmTop instr]		-- ^ code with unneeded spill\/reloads cleaned out
+	, raFinal	:: [NatCmmTop instr] 		-- ^ final code
 	, raSRMs	:: (Int, Int, Int) }		-- ^ spill\/reload\/reg-reg moves present in this code
 
-instance Outputable RegAllocStats where
+instance Outputable instr => Outputable (RegAllocStats instr) 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)
+--	$$ 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 ""
+--	$$ text "#  Register conflict graph."
+--	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+--	$$ text ""
 
 	$$ (if (not $ isNullUFM $ raCoalesced s)
 		then 	text "#  Registers coalesced."
@@ -86,9 +85,9 @@ instance Outputable RegAllocStats where
 			$$ text ""
 		else empty)
 
-	$$ text "#  Spill costs.  reg uses defs lifetime degree cost"
-	$$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
-	$$ text ""
+--	$$ text "#  Spill costs.  reg uses defs lifetime degree cost"
+--	$$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
+--	$$ text ""
 
 	$$ text "#  Spills inserted."
 	$$ ppr (raSpillStats s)
@@ -101,13 +100,13 @@ instance Outputable RegAllocStats where
  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 (initial)."
+--	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+--	$$ text ""
 
-	$$ text "#  Register conflict graph (colored)."
-	$$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
-	$$ text ""
+--	$$ text "#  Register conflict graph (colored)."
+--	$$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
+--	$$ text ""
 
 	$$ (if (not $ isNullUFM $ raCoalesced s)
 		then 	text "#  Registers coalesced."
@@ -133,7 +132,7 @@ instance Outputable RegAllocStats where
 	$$ text ""
 
 -- | Do all the different analysis on this list of RegAllocStats
-pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
+pprStats :: [RegAllocStats instr] -> Color.Graph Reg RegClass Reg -> SDoc
 pprStats stats graph
  = let 	outSpills	= pprStatsSpills    stats
 	outLife		= pprStatsLifetimes stats
@@ -145,7 +144,7 @@ pprStats stats graph
 
 -- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
 pprStatsSpills
-	:: [RegAllocStats] -> SDoc
+	:: [RegAllocStats instr] -> SDoc
 
 pprStatsSpills stats
  = let
@@ -163,7 +162,7 @@ pprStatsSpills stats
 
 -- | Dump a table of how long vregs tend to live for in the initial code.
 pprStatsLifetimes
-	:: [RegAllocStats] -> SDoc
+	:: [RegAllocStats instr] -> SDoc
 
 pprStatsLifetimes stats
  = let	info		= foldl' plusSpillCostInfo zeroSpillCostInfo
@@ -191,7 +190,7 @@ binLifetimeCount fm
 
 -- | Dump a table of how many conflicts vregs tend to have in the initial code.
 pprStatsConflict
-	:: [RegAllocStats] -> SDoc
+	:: [RegAllocStats instr] -> SDoc
 
 pprStatsConflict stats
  = let	confMap	= foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
@@ -208,7 +207,7 @@ pprStatsConflict stats
 -- | For every vreg, dump it's how many conflicts it has and its lifetime
 --	good for making a scatter plot.
 pprStatsLifeConflict
-	:: [RegAllocStats]
+	:: [RegAllocStats instr]
 	-> Color.Graph Reg RegClass Reg 	-- ^ global register conflict graph
 	-> SDoc
 
@@ -238,7 +237,10 @@ pprStatsLifeConflict stats graph
 -- | Count spill/reload/reg-reg moves.
 --	Lets us see how well the register allocator has done.
 --
-countSRMs :: LiveCmmTop -> (Int, Int, Int)
+countSRMs 
+	:: Instruction instr
+	=> LiveCmmTop instr -> (Int, Int, Int)
+
 countSRMs cmm
 	= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
 
@@ -246,16 +248,17 @@ countSRM_block (BasicBlock i instrs)
  = do	instrs'	<- mapM countSRM_instr instrs
  	return	$ BasicBlock i instrs'
 
-countSRM_instr li@(Instr instr _)
-	| SPILL _ _	<- instr
+countSRM_instr li
+	| SPILL _ _	<- li
 	= do	modify 	$ \(s, r, m)	-> (s + 1, r, m)
 		return li
 
-	| RELOAD _ _	<- instr
+	| RELOAD _ _	<- li
 	= do	modify	$ \(s, r, m)	-> (s, r + 1, m)
 		return li
 
-	| Just _		<- isRegRegMove instr
+	| Instr instr _	<- li
+	, Just _	<- takeRegRegMoveInstr instr
 	= do	modify	$ \(s, r, m)	-> (s, r, m + 1)
 		return li
 
@@ -266,77 +269,9 @@ countSRM_instr li@(Instr instr _)
 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
+
+
+
 
 
 {-
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
new file mode 100644
index 0000000000..6a7211dd06
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -0,0 +1,176 @@
+
+module RegAlloc.Graph.TrivColorable (
+	trivColorable,
+)
+
+where
+
+#include "HsVersions.h"
+
+import RegClass
+import Reg
+
+import GraphBase
+
+import UniqFM
+import FastTypes
+
+{-
+-- 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
+   = 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
+	RcFloat		-> panic "Regs.allocatableRegsInClass: no match\n"
+
+allocatableRegsInteger :: Int
+allocatableRegsInteger	
+	= length $ filter (\r -> regClass r == RcInteger) 
+		 $ map RealReg allocatableRegs
+
+allocatableRegsDouble :: Int
+allocatableRegsDouble
+	= length $ filter (\r -> regClass r == RcDouble) 
+		 $ map RealReg allocatableRegs
+-}
+
+
+-- trivColorable ---------------------------------------------------------------
+
+-- 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 "Regs.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 Regs.freeRegs  and MachRegs.h to get these numbers.
+--
+#if i386_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(6))
+#define ALLOCATABLE_REGS_FLOAT   (_ILIT(0))
+
+#elif x86_64_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(2))
+#define ALLOCATABLE_REGS_FLOAT   (_ILIT(0))
+
+#elif powerpc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(26))
+#define ALLOCATABLE_REGS_FLOAT   (_ILIT(0))
+
+#elif sparc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(6))
+#define ALLOCATABLE_REGS_FLOAT   (_ILIT(0))
+
+#else
+#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE
+#endif
+
+trivColorable 
+	:: (Reg -> RegClass) 
+	-> Triv Reg RegClass Reg
+	
+trivColorable regClass _ 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' #)
+
+			RcFloat 
+			 -> case cF +# _ILIT(1) of
+			 	cF' -> (# cF' >=# ALLOCATABLE_REGS_FLOAT,   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