PageRenderTime 51ms CodeModel.GetById 16ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/utils/UniqFM.lhs

https://bitbucket.org/carter/ghc
Haskell | 274 lines | 211 code | 46 blank | 17 comment | 1 complexity | ac99f48b1baf2ea479fbb0a2ff39276a MD5 | raw file
  1. %
  2. % (c) The University of Glasgow 2006
  3. % (c) The AQUA Project, Glasgow University, 1994-1998
  4. %
  5. UniqFM: Specialised finite maps, for things with @Uniques@.
  6. Basically, the things need to be in class @Uniquable@, and we use the
  7. @getUnique@ method to grab their @Uniques@.
  8. (A similar thing to @UniqSet@, as opposed to @Set@.)
  9. The interface is based on @FiniteMap@s, but the implementation uses
  10. @Data.IntMap@, which is both maitained and faster than the past
  11. implementation (see commit log).
  12. The @UniqFM@ interface maps directly to Data.IntMap, only
  13. ``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased
  14. and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
  15. of arguments of combining function.
  16. \begin{code}
  17. {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  18. {-# OPTIONS -Wall #-}
  19. module UniqFM (
  20. -- * Unique-keyed mappings
  21. UniqFM, -- abstract type
  22. -- ** Manipulating those mappings
  23. emptyUFM,
  24. unitUFM,
  25. unitDirectlyUFM,
  26. listToUFM,
  27. listToUFM_Directly,
  28. listToUFM_C,
  29. addToUFM,addToUFM_C,addToUFM_Acc,
  30. addListToUFM,addListToUFM_C,
  31. addToUFM_Directly,
  32. addListToUFM_Directly,
  33. adjustUFM, alterUFM,
  34. adjustUFM_Directly,
  35. delFromUFM,
  36. delFromUFM_Directly,
  37. delListFromUFM,
  38. plusUFM,
  39. plusUFM_C,
  40. minusUFM,
  41. intersectUFM,
  42. intersectUFM_C,
  43. foldUFM, foldUFM_Directly,
  44. mapUFM, mapUFM_Directly,
  45. elemUFM, elemUFM_Directly,
  46. filterUFM, filterUFM_Directly, partitionUFM,
  47. sizeUFM,
  48. isNullUFM,
  49. lookupUFM, lookupUFM_Directly,
  50. lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
  51. eltsUFM, keysUFM, splitUFM,
  52. ufmToList,
  53. joinUFM
  54. ) where
  55. import Unique ( Uniquable(..), Unique, getKey )
  56. import Outputable
  57. import Compiler.Hoopl hiding (Unique)
  58. import Data.Function (on)
  59. import qualified Data.IntMap as M
  60. import qualified Data.Foldable as Foldable
  61. import qualified Data.Traversable as Traversable
  62. import Data.Typeable
  63. import Data.Data
  64. \end{code}
  65. %************************************************************************
  66. %* *
  67. \subsection{The signature of the module}
  68. %* *
  69. %************************************************************************
  70. \begin{code}
  71. emptyUFM :: UniqFM elt
  72. isNullUFM :: UniqFM elt -> Bool
  73. unitUFM :: Uniquable key => key -> elt -> UniqFM elt
  74. unitDirectlyUFM -- got the Unique already
  75. :: Unique -> elt -> UniqFM elt
  76. listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
  77. listToUFM_Directly
  78. :: [(Unique, elt)] -> UniqFM elt
  79. listToUFM_C :: Uniquable key => (elt -> elt -> elt)
  80. -> [(key, elt)]
  81. -> UniqFM elt
  82. addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
  83. addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
  84. addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
  85. addToUFM_Directly
  86. :: UniqFM elt -> Unique -> elt -> UniqFM elt
  87. addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
  88. -> UniqFM elt -- old
  89. -> key -> elt -- new
  90. -> UniqFM elt -- result
  91. addToUFM_Acc :: Uniquable key =>
  92. (elt -> elts -> elts) -- Add to existing
  93. -> (elt -> elts) -- New element
  94. -> UniqFM elts -- old
  95. -> key -> elt -- new
  96. -> UniqFM elts -- result
  97. alterUFM :: Uniquable key =>
  98. (Maybe elt -> Maybe elt) -- How to adjust
  99. -> UniqFM elt -- old
  100. -> key -- new
  101. -> UniqFM elt -- result
  102. addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
  103. -> UniqFM elt -> [(key,elt)]
  104. -> UniqFM elt
  105. adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
  106. adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
  107. delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
  108. delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
  109. delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
  110. -- Bindings in right argument shadow those in the left
  111. plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
  112. plusUFM_C :: (elt -> elt -> elt)
  113. -> UniqFM elt -> UniqFM elt -> UniqFM elt
  114. minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
  115. intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
  116. intersectUFM_C :: (elt1 -> elt2 -> elt3)
  117. -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
  118. foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
  119. foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
  120. mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
  121. mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
  122. filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
  123. filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
  124. partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
  125. sizeUFM :: UniqFM elt -> Int
  126. --hashUFM :: UniqFM elt -> Int
  127. elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
  128. elemUFM_Directly:: Unique -> UniqFM elt -> Bool
  129. splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
  130. -- Splits a UFM into things less than, equal to, and greater than the key
  131. lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
  132. lookupUFM_Directly -- when you've got the Unique already
  133. :: UniqFM elt -> Unique -> Maybe elt
  134. lookupWithDefaultUFM
  135. :: Uniquable key => UniqFM elt -> elt -> key -> elt
  136. lookupWithDefaultUFM_Directly
  137. :: UniqFM elt -> elt -> Unique -> elt
  138. keysUFM :: UniqFM elt -> [Unique] -- Get the keys
  139. eltsUFM :: UniqFM elt -> [elt]
  140. ufmToList :: UniqFM elt -> [(Unique, elt)]
  141. \end{code}
  142. %************************************************************************
  143. %* *
  144. \subsection{Implementation using ``Data.IntMap''}
  145. %* *
  146. %************************************************************************
  147. \begin{code}
  148. newtype UniqFM ele = UFM { unUFM :: M.IntMap ele }
  149. deriving (Typeable,Data, Traversable.Traversable, Functor)
  150. instance Eq ele => Eq (UniqFM ele) where
  151. (==) = (==) `on` unUFM
  152. {-
  153. instance Functor UniqFM where
  154. fmap f = fmap f . unUFM
  155. instance Traversable.Traversable UniqFM where
  156. traverse f = Traversable.traverse f . unUFM
  157. -}
  158. instance Foldable.Foldable UniqFM where
  159. foldMap f = Foldable.foldMap f . unUFM
  160. emptyUFM = UFM M.empty
  161. isNullUFM (UFM m) = M.null m
  162. unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
  163. unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
  164. listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
  165. listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
  166. listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
  167. alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
  168. addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
  169. addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
  170. addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
  171. addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
  172. -- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
  173. addToUFM_C f (UFM m) k v =
  174. UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
  175. addToUFM_Acc exi new (UFM m) k v =
  176. UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
  177. addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
  178. adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
  179. adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
  180. delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
  181. delListFromUFM = foldl delFromUFM
  182. delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
  183. -- M.union is left-biased, plusUFM should be right-biased.
  184. plusUFM (UFM x) (UFM y) = UFM (M.union y x)
  185. plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
  186. minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
  187. intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
  188. intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
  189. foldUFM k z (UFM m) = M.fold k z m
  190. foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
  191. mapUFM f (UFM m) = UFM (M.map f m)
  192. mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
  193. filterUFM p (UFM m) = UFM (M.filter p m)
  194. filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
  195. partitionUFM p (UFM m) = case M.partition p m of
  196. (left, right) -> (UFM left, UFM right)
  197. sizeUFM (UFM m) = M.size m
  198. elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
  199. elemUFM_Directly u (UFM m) = M.member (getKey u) m
  200. splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
  201. (less, equal, greater) -> (UFM less, equal, UFM greater)
  202. lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
  203. lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
  204. lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
  205. lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
  206. keysUFM (UFM m) = map getUnique $ M.keys m
  207. eltsUFM (UFM m) = M.elems m
  208. ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
  209. -- Hoopl
  210. joinUFM :: JoinFun v -> JoinFun (UniqFM v)
  211. joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
  212. where add k new_v (ch, joinmap) =
  213. case lookupUFM_Directly joinmap k of
  214. Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
  215. Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
  216. (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
  217. (NoChange, _) -> (ch, joinmap)
  218. \end{code}
  219. %************************************************************************
  220. %* *
  221. \subsection{Output-ery}
  222. %* *
  223. %************************************************************************
  224. \begin{code}
  225. instance Outputable a => Outputable (UniqFM a) where
  226. ppr ufm = ppr (ufmToList ufm)
  227. \end{code}