module BlockId
( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
- , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
- , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
+ , 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
import Unique
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
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
-type BlockEnv a = UniqFM {- BlockId -} a
+blockLbl :: BlockId -> CLabel
+blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+
+-- Block environments: Id blocks
+newtype BlockEnv a = BlockEnv (UniqFM {- id -} 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 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
+
+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
projects / ghc-hetmet.git / blobdiff