2 ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
3 , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
4 , mkBlockEnv, mapBlockEnv
5 , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
6 , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
7 , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
8 , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
9 , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
10 , blockLbl, infoTblLbl, retPtLbl
22 ----------------------------------------------------------------
23 --- Block Ids, their environments, and their sets
25 {- Note [Unique BlockId]
26 ~~~~~~~~~~~~~~~~~~~~~~~~
27 Although a 'BlockId' is a local label, for reasons of implementation,
28 'BlockId's must be unique within an entire compilation unit. The reason
29 is that each local label is mapped to an assembly-language label, and in
30 most assembly languages allow, a label is visible throughout the entire
31 compilation unit in which it appears.
34 data BlockId = BlockId Unique
37 instance Uniquable BlockId where
38 getUnique (BlockId id) = id
40 mkBlockId :: Unique -> BlockId
41 mkBlockId uniq = BlockId uniq
43 instance Show BlockId where
44 show (BlockId u) = show u
46 instance Outputable BlockId where
47 ppr (BlockId id) = ppr id
49 retPtLbl :: BlockId -> CLabel
50 retPtLbl (BlockId id) = mkReturnPtLabel id
52 blockLbl :: BlockId -> CLabel
53 blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
55 infoTblLbl :: BlockId -> CLabel
56 infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
58 -- Block environments: Id blocks
59 newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
61 instance Outputable a => Outputable (BlockEnv a) where
62 ppr (BlockEnv env) = ppr env
64 -- This is pretty horrid. There must be common patterns here that can be
65 -- abstracted into wrappers.
66 emptyBlockEnv :: BlockEnv a
67 emptyBlockEnv = BlockEnv emptyUFM
69 isNullBEnv :: BlockEnv a -> Bool
70 isNullBEnv (BlockEnv env) = isNullUFM env
72 sizeBEnv :: BlockEnv a -> Int
73 sizeBEnv (BlockEnv env) = sizeUFM env
75 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
76 mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
78 eltsBlockEnv :: BlockEnv elt -> [elt]
79 eltsBlockEnv (BlockEnv env) = eltsUFM env
81 delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt
82 delFromBlockEnv (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
84 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
85 lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
87 elemBlockEnv :: BlockEnv a -> BlockId -> Bool
88 elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
90 lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
91 lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
93 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
94 extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
96 mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
97 mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
99 foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
100 foldBlockEnv f b (BlockEnv env) =
101 foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
103 foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
104 foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
106 plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
107 plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
109 blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
110 blockEnvToList (BlockEnv env) =
111 map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
113 addToBEnv_Acc :: (elt -> elts -> elts) -- Add to existing
114 -> (elt -> elts) -- New element
115 -> BlockEnv elts -- old
116 -> BlockId -> elt -- new
117 -> BlockEnv elts -- result
118 addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
119 BlockEnv (addToUFM_Acc add new old k v)
120 -- I believe this is only used by obsolete code.
123 newtype BlockSet = BlockSet (UniqSet Unique)
124 instance Outputable BlockSet where
125 ppr (BlockSet set) = ppr set
128 emptyBlockSet :: BlockSet
129 emptyBlockSet = BlockSet emptyUniqSet
131 isEmptyBlockSet :: BlockSet -> Bool
132 isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
134 unitBlockSet :: BlockId -> BlockSet
135 unitBlockSet = extendBlockSet emptyBlockSet
137 elemBlockSet :: BlockId -> BlockSet -> Bool
138 elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
140 extendBlockSet :: BlockSet -> BlockId -> BlockSet
141 extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
143 removeBlockSet :: BlockSet -> BlockId -> BlockSet
144 removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
146 mkBlockSet :: [BlockId] -> BlockSet
147 mkBlockSet = foldl extendBlockSet emptyBlockSet
149 unionBlockSets :: BlockSet -> BlockSet -> BlockSet
150 unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
152 sizeBlockSet :: BlockSet -> Int
153 sizeBlockSet (BlockSet set) = sizeUniqSet set
155 blockSetToList :: BlockSet -> [BlockId]
156 blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
158 foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
159 foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set