+{- 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
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
projects / ghc-hetmet.git / blobdiff