X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=5b867f3eff3f0e86b26935b5b67cf73fd02cc6d3;hb=b7f448a4ebb2b924f279bf49432f07338f41a764;hp=1ba241f92ddbe9228f2eb06d3c19cd144b9919cf;hpb=4839f119310cd82dec679239e0897e4a2a26ee92;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 1ba241f..5b867f3 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -5,7 +5,7 @@
 -- (c) The University of Glasgow 2004
 --
 -----------------------------------------------------------------------------
-
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module RegLiveness (
 	RegSet,
@@ -54,9 +54,13 @@ import Data.Maybe
 type RegSet = UniqSet Reg
 
 type RegMap a = UniqFM a
+
+emptyRegMap :: UniqFM a
 emptyRegMap = emptyUFM
 
 type BlockMap a = UniqFM a
+
+emptyBlockMap :: UniqFM a
 emptyBlockMap = emptyUFM
 
 
@@ -65,7 +69,7 @@ type LiveCmmTop
 	= GenCmmTop
 		CmmStatic
 		LiveInfo
-		(GenBasicBlock LiveInstr)
+		(ListGraph (GenBasicBlock LiveInstr))
 			-- the "instructions" here are actually more blocks,
 			--	single blocks are acyclic
 			--	multiple blocks are taken to be cyclic.
@@ -143,12 +147,12 @@ mapBlockTopM
 	=> (LiveBasicBlock -> m LiveBasicBlock)
 	-> LiveCmmTop -> m LiveCmmTop
 
-mapBlockTopM f cmm@(CmmData{})
+mapBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapBlockTopM f (CmmProc header label params comps)
+mapBlockTopM f (CmmProc header label params (ListGraph comps))
  = do	comps'	<- mapM (mapBlockCompM f) comps
- 	return	$ CmmProc header label params comps'
+ 	return	$ CmmProc header label params (ListGraph comps')
 
 mapBlockCompM f (BasicBlock i blocks)
  = do	blocks'	<- mapM f blocks
@@ -157,8 +161,8 @@ mapBlockCompM f (BasicBlock i blocks)
 
 -- map a function across all the basic blocks in this code
 mapGenBlockTop
-	:: (GenBasicBlock i -> GenBasicBlock i)
-	-> (GenCmmTop d h i -> GenCmmTop d h i)
+	:: (GenBasicBlock             i -> GenBasicBlock            i)
+	-> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
 
 mapGenBlockTop f cmm
 	= evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
@@ -167,39 +171,47 @@ mapGenBlockTop f cmm
 -- | map a function across all the basic blocks in this code (monadic version)
 mapGenBlockTopM
 	:: Monad m
-	=> (GenBasicBlock i -> m (GenBasicBlock i))
-	-> (GenCmmTop d h i -> m (GenCmmTop d h i))
+	=> (GenBasicBlock            i  -> m (GenBasicBlock            i))
+	-> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
 
-mapGenBlockTopM f cmm@(CmmData{})
+mapGenBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapGenBlockTopM f (CmmProc header label params blocks)
+mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
  = do	blocks'	<- mapM f blocks
- 	return	$ CmmProc header label params blocks'
+ 	return	$ CmmProc header label params (ListGraph blocks')
 
 
--- | Slurp out the list of register conflicts from this top level thing.
-
-slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
+-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
+--	Slurping of conflicts and moves is wrapped up together so we don't have
+--	to make two passes over the same code when we want to build the graph.
+--
+slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
 slurpConflicts live
-	= slurpCmm emptyBag live
+	= slurpCmm (emptyBag, emptyBag) live
 
  where	slurpCmm   rs  CmmData{}		= rs
- 	slurpCmm   rs (CmmProc info _ _ blocks)	
+ 	slurpCmm   rs (CmmProc info _ _ (ListGraph blocks))
 		= foldl' (slurpComp info) rs blocks
 
-	slurpComp  info rs (BasicBlock i blocks)	
+	slurpComp  info rs (BasicBlock _ blocks)	
 		= foldl' (slurpBlock info) rs blocks
 
 	slurpBlock info rs (BasicBlock blockId instrs)	
 		| LiveInfo _ _ blockLive	<- info
 		, Just rsLiveEntry		<- lookupUFM blockLive blockId
-		= consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
+		, (conflicts, moves)		<- slurpLIs rsLiveEntry rs instrs
+		= (consBag rsLiveEntry conflicts, moves)
+
+		| otherwise
+		= error "RegLiveness.slurpBlock: bad block"
+
+	slurpLIs rsLive (conflicts, moves) []
+		= (consBag rsLive conflicts, moves)
 
-	slurpLIs rsLive rs []				= consBag rsLive rs
 	slurpLIs rsLive rs (Instr _ Nothing     : lis)	= slurpLIs rsLive rs lis
 		
-	slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
+	slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
 	 = let
 		-- regs that die because they are read for the last time at the start of an instruction
 		--	are not live across it.
@@ -221,7 +233,14 @@ slurpConflicts live
 		--
 		rsConflicts	= unionUniqSets rsLiveNext rsOrphans
 
-	  in	slurpLIs rsLiveNext (consBag rsConflicts rs) lis
+	  in	case isRegRegMove instr of
+	  	 Just rr	-> slurpLIs rsLiveNext
+		 			( consBag rsConflicts conflicts
+					, consBag rr moves) lis
+
+	  	 Nothing	-> slurpLIs rsLiveNext
+		 			( consBag rsConflicts conflicts
+					, moves) lis
 
 
 -- | Strip away liveness information, yielding NatCmmTop
@@ -231,10 +250,10 @@ stripLive live
 	= stripCmm live
 
  where	stripCmm (CmmData sec ds)	= CmmData sec ds
- 	stripCmm (CmmProc (LiveInfo info _ _) label params comps)
-		= CmmProc info label params (concatMap stripComp comps)
+ 	stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
+		= CmmProc info label params (ListGraph $ concatMap stripComp comps)
 
-	stripComp  (BasicBlock i blocks)	= map stripBlock blocks
+	stripComp  (BasicBlock _ blocks)	= map stripBlock blocks
 	stripBlock (BasicBlock i instrs)	= BasicBlock i (map stripLI instrs)
 	stripLI    (Instr instr _)		= instr
 
@@ -242,15 +261,15 @@ stripLive live
 -- | Make real spill instructions out of SPILL, RELOAD pseudos
 
 spillNatBlock :: NatBasicBlock -> NatBasicBlock
-spillNatBlock (BasicBlock i instrs)
+spillNatBlock (BasicBlock i is)
  = 	BasicBlock i instrs'
  where 	(instrs', _)
- 		= runState (spillNat [] instrs) 0
+ 		= runState (spillNat [] is) 0
 
 	spillNat acc []
 	 = 	return (reverse acc)
 
-	spillNat acc (instr@(DELTA i) : instrs)
+	spillNat acc (DELTA i : instrs)
 	 = do	put i
 	 	spillNat acc instrs
 
@@ -276,18 +295,21 @@ lifetimeCount cmm
 	= countCmm emptyUFM cmm
  where
 	countCmm fm  CmmData{}		= fm
-	countCmm fm (CmmProc info _ _ blocks)
+	countCmm fm (CmmProc info _ _ (ListGraph blocks))
 		= foldl' (countComp info) fm blocks
 		
-	countComp info fm (BasicBlock i blocks)
+	countComp info fm (BasicBlock _ blocks)
 		= foldl' (countBlock info) fm blocks
 		
  	countBlock info fm (BasicBlock blockId instrs)
 		| LiveInfo _ _ blockLive	<- info
 		, Just rsLiveEntry		<- lookupUFM blockLive blockId
 		= countLIs rsLiveEntry fm instrs
+
+		| otherwise
+		= error "RegLiveness.countBlock: bad block"
 		
-	countLIs rsLive fm []				= fm
+	countLIs _      fm []				= fm
 	countLIs rsLive fm (Instr _ Nothing : lis)	= countLIs rsLive fm lis
 	
 	countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
@@ -333,13 +355,13 @@ patchEraseLive patchF cmm
  where
 	patchCmm cmm@CmmData{}	= cmm
 
-	patchCmm cmm@(CmmProc info label params comps)
+	patchCmm (CmmProc info label params (ListGraph comps))
 	 | LiveInfo static id blockMap	<- info
 	 = let 	patchRegSet set	= mkUniqSet $ map patchF $ uniqSetToList set
 		blockMap'	= mapUFM patchRegSet blockMap
 
 		info'		= LiveInfo static id blockMap'
-	   in	CmmProc info' label params $ map patchComp comps
+	   in	CmmProc info' label params $ ListGraph $ map patchComp comps
 
 	patchComp (BasicBlock id blocks)
 		= BasicBlock id $ map patchBlock blocks
@@ -400,15 +422,15 @@ regLiveness
 	:: NatCmmTop
 	-> UniqSM LiveCmmTop
 
-regLiveness cmm@(CmmData sec d)
-	= returnUs $ CmmData sec d
+regLiveness (CmmData i d)
+	= returnUs $ CmmData i d
 
-regLiveness cmm@(CmmProc info lbl params [])
+regLiveness (CmmProc info lbl params (ListGraph []))
 	= returnUs $ CmmProc
 			(LiveInfo info Nothing emptyUFM)
-			lbl params []
+			lbl params (ListGraph [])
 
-regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
+regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
  = let 	first_id		= blockId first
 	sccs			= sccBlocks blocks
 	(ann_sccs, block_live)	= computeLiveness sccs
@@ -423,7 +445,7 @@ regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
 
    in	returnUs $ CmmProc
 			(LiveInfo info (Just first_id) block_live)
-			lbl params liveBlocks
+			lbl params (ListGraph liveBlocks)
 
 
 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
@@ -507,7 +529,7 @@ livenessBlock
 	-> NatBasicBlock
 	-> (BlockMap RegSet, LiveBasicBlock)
 
-livenessBlock blockmap block@(BasicBlock block_id instrs)
+livenessBlock blockmap (BasicBlock block_id instrs)
  = let
  	(regsLiveOnEntry, instrs1)
  		= livenessBack emptyUniqSet blockmap [] (reverse instrs)
@@ -526,13 +548,13 @@ livenessForward
 	:: RegSet			-- regs live on this instr
 	-> [LiveInstr] -> [LiveInstr]
 
-livenessForward rsLiveEntry []	= []
+livenessForward _           []	= []
 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 	| Nothing		<- mLive
 	= li : livenessForward rsLiveEntry lis
 
-	| Just live		<- mLive
-	, RU read written	<- regUsage instr
+	| Just live	<- mLive
+	, RU _ written	<- regUsage instr
 	= let
 		-- Regs that are written to but weren't live on entry to this instruction
 		--	are recorded as being born here.
@@ -546,6 +568,8 @@ livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 	in Instr instr (Just live { liveBorn = rsBorn })
 		: livenessForward rsLiveNext lis
 
+livenessForward _ _ 		= panic "RegLiveness.livenessForward: no match"
+
 
 -- | Calculate liveness going backwards,
 --	filling in when regs die, and what regs are live across each instruction
@@ -557,17 +581,17 @@ livenessBack
 	-> [Instr]			-- instructions
 	-> (RegSet, [LiveInstr])
 
-livenessBack liveregs blockmap done []  = (liveregs, done)
+livenessBack liveregs _        done []  = (liveregs, done)
 
 livenessBack liveregs blockmap acc (instr : instrs)
  = let	(liveregs', instr')	= liveness1 liveregs blockmap instr
    in	livenessBack liveregs' blockmap (instr' : acc) instrs
 
 -- don't bother tagging comments or deltas with liveness
-liveness1 liveregs blockmap (instr@COMMENT{})
+liveness1 liveregs _   (instr@COMMENT{})
 	= (liveregs, Instr instr Nothing)
 
-liveness1 liveregs blockmap (instr@DELTA{})
+liveness1 liveregs _   (instr@DELTA{})
 	= (liveregs, Instr instr Nothing)
 
 liveness1 liveregs blockmap instr