X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FBlockId.hs;h=c28201c92b491a55077104a32dcd32c5fbcecbf4;hp=01ddcd2b95cec581708c2856806dfc673c92b7e9;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index 01ddcd2..c28201c 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -1,23 +1,21 @@
+{- 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
-  , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
-  , mkBlockEnv, mapBlockEnv
-  , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
-  , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
-  , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
-  , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
-  , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , BlockSet, BlockEnv
+  , IsSet(..), setInsertList, setDeleteList, setUnions
+  , IsMap(..), mapInsertList, mapDeleteList, mapUnions
+  , emptyBlockSet, emptyBlockMap
   , blockLbl, infoTblLbl, retPtLbl
   ) where
 
 import CLabel
 import IdInfo
-import Maybes
 import Name
 import Outputable
-import UniqFM
 import Unique
-import UniqSet
+
+import Compiler.Hoopl hiding (Unique)
+import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
 
 ----------------------------------------------------------------
 --- Block Ids, their environments, and their sets
@@ -31,129 +29,40 @@ most assembly languages allow, a label is visible throughout the entire
 compilation unit in which it appears.
 -}
 
-data BlockId = BlockId Unique
-  deriving (Eq,Ord)
+type BlockId = Label
 
 instance Uniquable BlockId where
-  getUnique (BlockId id) = id
+  getUnique label = getUnique (uniqueToInt $ lblToUnique label)
 
 mkBlockId :: Unique -> BlockId
-mkBlockId uniq = BlockId uniq
-
-instance Show BlockId where
-  show (BlockId u) = show u
+mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
 
 instance Outputable BlockId where
-  ppr (BlockId id) = ppr id
+  ppr label = ppr (getUnique label)
 
 retPtLbl :: BlockId -> CLabel
-retPtLbl (BlockId id) = mkReturnPtLabel id
+retPtLbl label = mkReturnPtLabel $ getUnique label
 
 blockLbl :: BlockId -> CLabel
-blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
+blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
 
 infoTblLbl :: BlockId -> CLabel
-infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
 
 -- Block environments: Id blocks
-newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
+type BlockEnv a = LabelMap a
 
 instance Outputable a => Outputable (BlockEnv a) where
-  ppr (BlockEnv env) = ppr env
-
--- This is pretty horrid. There must be common patterns here that can be
--- abstracted into wrappers.
-emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = BlockEnv emptyUFM
-
-isNullBEnv :: BlockEnv a -> Bool
-isNullBEnv (BlockEnv env) = isNullUFM env
-
-sizeBEnv :: BlockEnv a -> Int
-sizeBEnv (BlockEnv env)  = sizeUFM env
-
-mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
-
-eltsBlockEnv :: BlockEnv elt -> [elt]
-eltsBlockEnv (BlockEnv env) = eltsUFM env
-
-delFromBlockEnv	:: BlockEnv elt -> BlockId -> BlockEnv elt
-delFromBlockEnv	  (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
-
-lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
-
-elemBlockEnv :: BlockEnv a -> BlockId -> Bool
-elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
-
-lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
-lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
-
-extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
-
-mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
-
-foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f b (BlockEnv env) = 
-  foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+  ppr = ppr . mapToList
 
-foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = mapEmpty
 
-plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
-plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+-- Block sets
+type BlockSet = LabelSet
 
-blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
-blockEnvToList (BlockEnv env) =
-  map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
-
-addToBEnv_Acc	:: (elt -> elts -> elts)	-- Add to existing
-			   -> (elt -> elts)		-- New element
-			   -> BlockEnv elts 		-- old
-			   -> BlockId -> elt 		-- new
-			   -> BlockEnv elts		-- result
-addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
-  BlockEnv (addToUFM_Acc add new old k v)
-  -- I believe this is only used by obsolete code.
-
-
-newtype BlockSet = BlockSet (UniqSet Unique)
 instance Outputable BlockSet where
-  ppr (BlockSet set) = ppr set
-
+  ppr = ppr . setElems
 
 emptyBlockSet :: BlockSet
-emptyBlockSet = BlockSet emptyUniqSet
-
-isEmptyBlockSet :: BlockSet -> Bool
-isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
-
-unitBlockSet :: BlockId -> BlockSet
-unitBlockSet = extendBlockSet emptyBlockSet
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
-
-removeBlockSet :: BlockSet -> BlockId -> BlockSet
-removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = foldl extendBlockSet emptyBlockSet
-
-unionBlockSets :: BlockSet -> BlockSet -> BlockSet
-unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
-
-sizeBlockSet :: BlockSet -> Int
-sizeBlockSet (BlockSet set) = sizeUniqSet set
-
-blockSetToList :: BlockSet -> [BlockId]
-blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
-
-foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
-foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
+emptyBlockSet = setEmpty