never executed always true always false
1 {-# LANGUAGE DeriveTraversable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE TypeFamilies #-}
6
7 module GHC.Cmm.Dataflow.Label
8 ( Label
9 , LabelMap
10 , LabelSet
11 , FactBase
12 , lookupFact
13 , mkHooplLabel
14 ) where
15
16 import GHC.Prelude
17
18 import GHC.Utils.Outputable
19
20 -- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
21 import GHC.Cmm.Dataflow.Collections
22
23 import GHC.Types.Unique (Uniquable(..))
24 import GHC.Data.TrieMap
25
26
27 -----------------------------------------------------------------------------
28 -- Label
29 -----------------------------------------------------------------------------
30
31 newtype Label = Label { lblToUnique :: Int }
32 deriving (Eq, Ord)
33
34 mkHooplLabel :: Int -> Label
35 mkHooplLabel = Label
36
37 instance Show Label where
38 show (Label n) = "L" ++ show n
39
40 instance Uniquable Label where
41 getUnique label = getUnique (lblToUnique label)
42
43 instance Outputable Label where
44 ppr label = ppr (getUnique label)
45
46 instance OutputableP env Label where
47 pdoc _ l = ppr l
48
49 -----------------------------------------------------------------------------
50 -- LabelSet
51
52 newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
53
54 instance IsSet LabelSet where
55 type ElemOf LabelSet = Label
56
57 setNull (LS s) = setNull s
58 setSize (LS s) = setSize s
59 setMember (Label k) (LS s) = setMember k s
60
61 setEmpty = LS setEmpty
62 setSingleton (Label k) = LS (setSingleton k)
63 setInsert (Label k) (LS s) = LS (setInsert k s)
64 setDelete (Label k) (LS s) = LS (setDelete k s)
65
66 setUnion (LS x) (LS y) = LS (setUnion x y)
67 setDifference (LS x) (LS y) = LS (setDifference x y)
68 setIntersection (LS x) (LS y) = LS (setIntersection x y)
69 setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
70 setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
71 setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
72 setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
73
74 setElems (LS s) = map mkHooplLabel (setElems s)
75 setFromList ks = LS (setFromList (map lblToUnique ks))
76
77 -----------------------------------------------------------------------------
78 -- LabelMap
79
80 newtype LabelMap v = LM (UniqueMap v)
81 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
82
83 instance IsMap LabelMap where
84 type KeyOf LabelMap = Label
85
86 mapNull (LM m) = mapNull m
87 mapSize (LM m) = mapSize m
88 mapMember (Label k) (LM m) = mapMember k m
89 mapLookup (Label k) (LM m) = mapLookup k m
90 mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
91
92 mapEmpty = LM mapEmpty
93 mapSingleton (Label k) v = LM (mapSingleton k v)
94 mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
95 mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
96 mapDelete (Label k) (LM m) = LM (mapDelete k m)
97 mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
98 mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
99
100 mapUnion (LM x) (LM y) = LM (mapUnion x y)
101 mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
102 mapDifference (LM x) (LM y) = LM (mapDifference x y)
103 mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
104 mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
105
106 mapMap f (LM m) = LM (mapMap f m)
107 mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
108 mapFoldl k z (LM m) = mapFoldl k z m
109 mapFoldr k z (LM m) = mapFoldr k z m
110 mapFoldlWithKey k z (LM m) =
111 mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
112 mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
113 {-# INLINEABLE mapFilter #-}
114 mapFilter f (LM m) = LM (mapFilter f m)
115 {-# INLINEABLE mapFilterWithKey #-}
116 mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
117
118 mapElems (LM m) = mapElems m
119 mapKeys (LM m) = map mkHooplLabel (mapKeys m)
120 {-# INLINEABLE mapToList #-}
121 mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
122 mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
123 mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
124
125 -----------------------------------------------------------------------------
126 -- Instances
127
128 instance Outputable LabelSet where
129 ppr = ppr . setElems
130
131 instance Outputable a => Outputable (LabelMap a) where
132 ppr = ppr . mapToList
133
134 instance OutputableP env a => OutputableP env (LabelMap a) where
135 pdoc env = pdoc env . mapToList
136
137 instance TrieMap LabelMap where
138 type Key LabelMap = Label
139 emptyTM = mapEmpty
140 lookupTM k m = mapLookup k m
141 alterTM k f m = mapAlter f k m
142 foldTM k m z = mapFoldr k z m
143 mapTM f m = mapMap f m
144 filterTM f m = mapFilter f m
145
146 -----------------------------------------------------------------------------
147 -- FactBase
148
149 type FactBase f = LabelMap f
150
151 lookupFact :: Label -> FactBase f -> Maybe f
152 lookupFact = mapLookup