1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
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
, blockLbl, infoTblLbl, retPtLbl
) where
import CLabel
import IdInfo
import Maybes
import Name
import Outputable
import UniqFM
import Unique
import UniqSet
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
{- Note [Unique BlockId]
~~~~~~~~~~~~~~~~~~~~~~~~
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 entire
compilation unit in which it appears.
-}
data BlockId = BlockId Unique
deriving (Eq,Ord)
instance Uniquable BlockId where
getUnique (BlockId id) = id
mkBlockId :: Unique -> BlockId
mkBlockId uniq = BlockId uniq
instance Show BlockId where
show (BlockId u) = show u
instance Outputable BlockId where
ppr (BlockId id) = ppr id
retPtLbl :: BlockId -> CLabel
retPtLbl (BlockId id) = mkReturnPtLabel id
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 = 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
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
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
|
