X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FNCGMonad.hs;h=2a7376838a9b96075de9d4e683165d8c0f928596;hp=721b6186e309da585502f6f111281b51ace4c63b;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf

diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 721b618..2a73768 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -6,69 +6,82 @@
 --
 -- -----------------------------------------------------------------------------
 
-{-# 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 NCGMonad (
 	NatM_State(..), mkNatM_State,
 
 	NatM, -- instance Monad
-	initNat, addImportNat, getUniqueNat,
-	mapAccumLNat, setDeltaNat, getDeltaNat,
-	getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
-	getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat
- ) where
+	initNat, 
+	addImportNat, 
+	getUniqueNat,
+	mapAccumLNat, 
+	setDeltaNat, 
+	getDeltaNat,
+	getBlockIdNat, 
+	getNewLabelNat, 
+	getNewRegNat, 
+	getNewRegPairNat,
+	getPicBaseMaybeNat, 
+	getPicBaseNat, 
+	getDynFlagsNat
+) 
+ 
+where
   
 #include "HsVersions.h"
 
-import Cmm		( BlockId(..) )
+import Reg
+import Size
+import TargetReg
+
+import BlockId
 import CLabel		( CLabel, mkAsmTempLabel )
-import MachRegs
-import MachOp		( MachRep )
 import UniqSupply
 import Unique		( Unique )
 import DynFlags
 
-data NatM_State = NatM_State {
-			natm_us      :: UniqSupply,
-			natm_delta   :: Int,
-			natm_imports :: [(CLabel)],
-			natm_pic     :: Maybe Reg,
-			natm_dflags  :: DynFlags
-		}
+data NatM_State 
+	= NatM_State {
+		natm_us      :: UniqSupply,
+		natm_delta   :: Int,
+		natm_imports :: [(CLabel)],
+		natm_pic     :: Maybe Reg,
+		natm_dflags  :: DynFlags
+	}
 
 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
 
+unNat :: NatM a -> NatM_State -> (a, NatM_State)
 unNat (NatM a) = a
 
 mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
-mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags
+mkNatM_State us delta dflags 
+	= NatM_State us delta [] Nothing dflags
 
 initNat :: NatM_State -> NatM a -> (a, NatM_State)
-initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
+initNat init_st m 
+	= case unNat m init_st of { (r,st) -> (r,st) }
+
 
 instance Monad NatM where
   (>>=) = thenNat
   return = returnNat
 
+
 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 thenNat expr cont
-  = NatM $ \st -> case unNat expr st of
+	= NatM $ \st -> case unNat expr st of
 			(result, st') -> unNat (cont result) st'
 
 returnNat :: a -> NatM a
-returnNat result = NatM $ \st ->  (result, st)
+returnNat result 
+	= NatM $ \st ->  (result, st)
 
 mapAccumLNat :: (acc -> x -> NatM (acc, y))
                 -> acc
 	        -> [x]
 	        -> NatM (acc, [y])
 
-mapAccumLNat f b []
+mapAccumLNat _ b []
   = return (b, [])
 mapAccumLNat f b (x:xs)
   = do (b__2, x__2)  <- f b x
@@ -77,48 +90,71 @@ mapAccumLNat f b (x:xs)
 
 getUniqueNat :: NatM Unique
 getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
-    case splitUniqSupply us of
-         (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags))
+    case takeUniqFromSupply us of
+         (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags))
 
 
 getDynFlagsNat :: NatM DynFlags
-getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
-		          (dflags, (NatM_State us delta imports pic dflags))
+getDynFlagsNat 
+	= NatM $ \ (NatM_State us delta imports pic dflags) ->
+	          (dflags, (NatM_State us delta imports pic dflags))
+
 
 getDeltaNat :: NatM Int
-getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+getDeltaNat 
+	= NatM $ \ st -> (natm_delta st, st)
+
 
 setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) ->
-   ((), NatM_State us delta imports pic dflags)
+setDeltaNat delta 
+	= NatM $ \ (NatM_State us _ imports pic dflags) ->
+		   ((), NatM_State us delta imports pic dflags)
+
 
 addImportNat :: CLabel -> NatM ()
-addImportNat imp = NatM $ \ (NatM_State us delta imports pic dflags) ->
-   ((), NatM_State us delta (imp:imports) pic dflags)
+addImportNat imp 
+	= NatM $ \ (NatM_State us delta imports pic dflags) ->
+		   ((), NatM_State us delta (imp:imports) pic dflags)
+
 
 getBlockIdNat :: NatM BlockId
-getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
+getBlockIdNat 
+ = do	u <- getUniqueNat
+ 	return (mkBlockId u)
+
 
 getNewLabelNat :: NatM CLabel
-getNewLabelNat = do u <- getUniqueNat; return (mkAsmTempLabel u)
+getNewLabelNat 
+ = do 	u <- getUniqueNat
+ 	return (mkAsmTempLabel u)
+
+
+getNewRegNat :: Size -> NatM Reg
+getNewRegNat rep 
+ = do	u <- getUniqueNat
+ 	return (RegVirtual $ targetMkVirtualReg u rep)
+
 
-getNewRegNat :: MachRep -> NatM Reg
-getNewRegNat rep = do u <- getUniqueNat; return (mkVReg u rep)
+getNewRegPairNat :: Size -> NatM (Reg,Reg)
+getNewRegPairNat rep 
+ = do	u 	<- getUniqueNat
+ 	let vLo	= targetMkVirtualReg u rep
+	let lo 	= RegVirtual $ targetMkVirtualReg u rep
+	let hi 	= RegVirtual $ getHiVirtualRegFromLo vLo
+	return (lo, hi)
 
-getNewRegPairNat :: MachRep -> NatM (Reg,Reg)
-getNewRegPairNat rep = do 
-  u <- getUniqueNat
-  let lo = mkVReg u rep; hi = getHiVRegFromLo lo
-  return (lo,hi)
 
 getPicBaseMaybeNat :: NatM (Maybe Reg)
-getPicBaseMaybeNat = NatM (\state -> (natm_pic state, state))
-
-getPicBaseNat :: MachRep -> NatM Reg
-getPicBaseNat rep = do
-  mbPicBase <- getPicBaseMaybeNat
-  case mbPicBase of
-        Just picBase -> return picBase
-        Nothing -> do
-            reg <- getNewRegNat rep
-            NatM (\state -> (reg, state { natm_pic = Just reg }))
+getPicBaseMaybeNat 
+	= NatM (\state -> (natm_pic state, state))
+
+
+getPicBaseNat :: Size -> NatM Reg
+getPicBaseNat rep 
+ = do	mbPicBase <- getPicBaseMaybeNat
+	case mbPicBase of
+	        Just picBase -> return picBase
+	        Nothing 
+		 -> do
+			reg <- getNewRegNat rep
+			NatM (\state -> (reg, state { natm_pic = Just reg }))