Use MonadUnique for newBlockId

4 files changed, 14 insertions, 8 deletions

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index e4cc0bc..49fc5a3 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -4,6 +4,7 @@
 {- BlockId module should probably go away completely, being superseded by Label -}
 module BlockId
   ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , newBlockId
   , BlockSet, BlockEnv
   , IsSet(..), setInsertList, setDeleteList, setUnions
   , IsMap(..), mapInsertList, mapDeleteList, mapUnions
@@ -16,6 +17,7 @@ import IdInfo
 import Name
 import Outputable
 import Unique
+import UniqSupply
 
 import Compiler.Hoopl as Hoopl hiding (Unique)
 import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
@@ -43,6 +45,9 @@ instance Outputable BlockId where
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
 
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
 retPtLbl :: BlockId -> CLabel
 retPtLbl label = mkReturnPtLabel $ getUnique label
 
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index a5daad1..10b7865 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -32,7 +32,6 @@ import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
 import Data.List (nub)
-import Control.Monad (liftM)
 
 import Prelude hiding ((<*>))
 
@@ -526,7 +525,7 @@ makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
 makeFixupBlock dflags sp0 l stack tscope assigs
   | null assigs && sp0 == sm_sp stack = return (l, [])
   | otherwise = do
-    tmp_lbl <- liftM mkBlockId $ getUniqueM
+    tmp_lbl <- newBlockId
     let sp_off = sp0 - sm_sp stack
         block = blockJoin (CmmEntry tmp_lbl tscope)
                           (maybeAddSpAdj dflags sp_off (blockFromList assigs))
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index f3bb6ee..f12ada2 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -43,13 +43,13 @@ import Cmm
 import CLabel
 import MkGraph
 
--- import BasicTypes
 import BlockId
 import DynFlags
 import FastString
 import Module
 import UniqFM
 import Unique
+import UniqSupply
 
 import Control.Monad (liftM, ap)
 
@@ -90,6 +90,12 @@ instance Applicative CmmParse where
 instance Monad CmmParse where
   (>>=) = thenExtFC
 
+instance MonadUnique CmmParse where
+  getUniqueSupplyM = code getUniqueSupplyM
+  getUniqueM = EC $ \_ _ decls -> do
+    u <- getUniqueM
+    return (decls, u)
+
 instance HasDynFlags CmmParse where
     getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
                                    return (d, dflags))
@@ -155,9 +161,6 @@ newLabel name = do
    addLabel name (mkBlockId u)
    return (mkBlockId u)
 
-newBlockId :: CmmParse BlockId
-newBlockId = code F.newLabelC
-
 -- | Add add a local function to the environment.
 newFunctionName
         :: FastString   -- ^ name of the function
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 175db2a..dac9082 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -749,8 +749,7 @@ emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
 
 
 newLabelC :: FCode BlockId
-newLabelC = do { u <- newUnique
-               ; return $ mkBlockId u }
+newLabelC = newBlockId
 
 emit :: CmmAGraph -> FCode ()
 emit ag