X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=c47ce96006b7b976e6734aa1b07161b06ffc6174;hb=272f0ba89eca1d9fc700cf4c27b9f8c3e23d6fe8;hp=4acb3be73a0d604c8bfe9e40b51a552f04158d6b;hpb=0f7d268d00795a58a06ae3c92ebbd14571295b84;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 4acb3be..c47ce96 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,
@@ -17,15 +17,17 @@ module RegLiveness (
 	LiveInfo (..),
 	LiveBasicBlock,
 
-	mapBlockTop,
-	mapBlockTopM,
+	mapBlockTop, 	mapBlockTopM,
+	mapGenBlockTop,	mapGenBlockTopM,
 	stripLive,
+	spillNatBlock,
 	slurpConflicts,
 	lifetimeCount,
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
 	regLiveness
+
   ) where
 
 #include "HsVersions.h"
@@ -52,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
 
 
@@ -141,7 +147,7 @@ mapBlockTopM
 	=> (LiveBasicBlock -> m LiveBasicBlock)
 	-> LiveCmmTop -> m LiveCmmTop
 
-mapBlockTopM f cmm@(CmmData{})
+mapBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
 mapBlockTopM f (CmmProc header label params comps)
@@ -153,28 +159,59 @@ mapBlockCompM f (BasicBlock i blocks)
  	return	$ BasicBlock i blocks'
 
 
--- | Slurp out the list of register conflicts from this top level thing.
+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+	:: (GenBasicBlock i -> GenBasicBlock i)
+	-> (GenCmmTop d h i -> GenCmmTop d h i)
 
-slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
+mapGenBlockTop f cmm
+	= evalState (mapGenBlockTopM (\x -> return $ f x) 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))
+
+mapGenBlockTopM _ cmm@(CmmData{})
+	= return cmm
+
+mapGenBlockTopM f (CmmProc header label params blocks)
+ = do	blocks'	<- mapM f blocks
+ 	return	$ CmmProc header label params blocks'
+
+
+-- | 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)	
 		= 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.
@@ -196,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
@@ -209,11 +253,38 @@ stripLive live
  	stripCmm (CmmProc (LiveInfo info _ _) label params comps)
 		= CmmProc info label params (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
 
 
+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i is)
+ = 	BasicBlock i instrs'
+ where 	(instrs', _)
+ 		= runState (spillNat [] is) 0
+
+	spillNat acc []
+	 = 	return (reverse acc)
+
+	spillNat acc (DELTA i : instrs)
+	 = do	put i
+	 	spillNat acc instrs
+
+	spillNat acc (SPILL reg slot : instrs)
+	 = do	delta	<- get
+	 	spillNat (mkSpillInstr reg delta slot : acc) instrs
+
+	spillNat acc (RELOAD slot reg : instrs)
+	 = do	delta	<- get
+	 	spillNat (mkLoadInstr reg delta slot : acc) instrs
+
+	spillNat acc (instr : instrs)
+	 =	spillNat (instr : acc) instrs
+
+
 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
 
 lifetimeCount
@@ -227,15 +298,18 @@ lifetimeCount cmm
 	countCmm fm (CmmProc info _ _ 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)
@@ -281,7 +355,7 @@ patchEraseLive patchF cmm
  where
 	patchCmm cmm@CmmData{}	= cmm
 
-	patchCmm cmm@(CmmProc info label params comps)
+	patchCmm (CmmProc info label params comps)
 	 | LiveInfo static id blockMap	<- info
 	 = let 	patchRegSet set	= mkUniqSet $ map patchF $ uniqSetToList set
 		blockMap'	= mapUFM patchRegSet blockMap
@@ -348,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 [])
 	= returnUs $ CmmProc
 			(LiveInfo info Nothing emptyUFM)
 			lbl params []
 
-regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
+regLiveness (CmmProc info lbl params blocks@(first : _))
  = let 	first_id		= blockId first
 	sccs			= sccBlocks blocks
 	(ann_sccs, block_live)	= computeLiveness sccs
@@ -455,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)
@@ -474,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.
@@ -494,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
@@ -505,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