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

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 4acb3be..737ce5a 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -6,6 +6,12 @@
 --
 -----------------------------------------------------------------------------
 
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
 
 module RegLiveness (
 	RegSet,
@@ -17,15 +23,17 @@ module RegLiveness (
 	LiveInfo (..),
 	LiveBasicBlock,
 
-	mapBlockTop,
-	mapBlockTopM,
+	mapBlockTop, 	mapBlockTopM,
+	mapGenBlockTop,	mapGenBlockTopM,
 	stripLive,
+	spillNatBlock,
 	slurpConflicts,
 	lifetimeCount,
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
 	regLiveness
+
   ) where
 
 #include "HsVersions.h"
@@ -153,6 +161,29 @@ mapBlockCompM f (BasicBlock i blocks)
  	return	$ 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)
+
+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 f 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 from this top level thing.
 
 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
@@ -214,6 +245,33 @@ stripLive live
 	stripLI    (Instr instr _)		= instr
 
 
+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i instrs)
+ = 	BasicBlock i instrs'
+ where 	(instrs', _)
+ 		= runState (spillNat [] instrs) 0
+
+	spillNat acc []
+	 = 	return (reverse acc)
+
+	spillNat acc (instr@(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