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

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index 2e4d452..01ddcd2 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -1,12 +1,18 @@
 module BlockId
   ( BlockId(..), mkBlockId 	-- ToDo: BlockId should be abstract, but it isn't yet
-  , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, mapBlockEnv
-  , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
-  , foldBlockEnv, blockLbl, infoTblLbl
+  , 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
+  , blockLbl, infoTblLbl, retPtLbl
   ) where
 
 import CLabel
 import IdInfo
+import Maybes
 import Name
 import Outputable
 import UniqFM
@@ -21,15 +27,15 @@ import UniqSet
 Although a 'BlockId' is a local label, for reasons of implementation,
 'BlockId's must be unique within an entire compilation unit.  The reason
 is that each local label is mapped to an assembly-language label, and in
-most assembly languages allow, a label is visible throughout the enitre
+most assembly languages allow, a label is visible throughout the entire
 compilation unit in which it appears.
 -}
 
-newtype BlockId = BlockId Unique
+data BlockId = BlockId Unique
   deriving (Eq,Ord)
 
 instance Uniquable BlockId where
-  getUnique (BlockId u) = u
+  getUnique (BlockId id) = id
 
 mkBlockId :: Unique -> BlockId
 mkBlockId uniq = BlockId uniq
@@ -38,36 +44,116 @@ instance Show BlockId where
   show (BlockId u) = show u
 
 instance Outputable BlockId where
-  ppr = ppr . getUnique
+  ppr (BlockId id) = ppr id
+
+retPtLbl :: BlockId -> CLabel
+retPtLbl (BlockId id) = mkReturnPtLabel id
 
 blockLbl :: BlockId -> CLabel
-blockLbl id = mkEntryLabel (mkFCallName (getUnique id) "block") NoCafRefs
+blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
 
 infoTblLbl :: BlockId -> CLabel
-infoTblLbl id = mkInfoTableLabel (mkFCallName (getUnique id) "block") NoCafRefs
+infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+
+-- Block environments: Id blocks
+newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
 
-type BlockEnv a = UniqFM {- BlockId -} 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 = emptyUFM
+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 = listToUFM
+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 = lookupUFM
+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 = addToUFM
+extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
+
 mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv = mapUFM
+mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
+
 foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f = foldUFM_Directly (\u x y -> f (mkBlockId u) x y)
+foldBlockEnv f b (BlockEnv env) = 
+  foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+
+foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
+foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+
+plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
+plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+
+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
+
 
-type BlockSet = UniqSet BlockId
 emptyBlockSet :: BlockSet
-emptyBlockSet = emptyUniqSet
+emptyBlockSet = BlockSet emptyUniqSet
+
+isEmptyBlockSet :: BlockSet -> Bool
+isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
+
+unitBlockSet :: BlockId -> BlockSet
+unitBlockSet = extendBlockSet emptyBlockSet
+
 elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet = elementOfUniqSet
+elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
+
 extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet = addOneToUniqSet
+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 = mkUniqSet
+mkBlockSet = foldl extendBlockSet emptyBlockSet
+
+unionBlockSets :: BlockSet -> BlockSet -> BlockSet
+unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
+
 sizeBlockSet :: BlockSet -> Int
-sizeBlockSet = sizeUniqSet
+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