%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
Based on @FiniteMaps@ (as you would expect).
Basically, the things need to be in class @Uniquable@, and we use the
-@uniqueOf@ method to grab their @Uniques@.
+@getUnique@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
\begin{code}
-#if defined(COMPILING_GHC)
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-#else
-#define ASSERT(e) {--}
-#define IF_NOT_GHC(a) a
-#endif
-
module UniqFM (
UniqFM, -- abstract type
- Uniquable(..), -- class to go with it
emptyUFM,
unitUFM,
unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
- addToUFM,
- addListToUFM,
+ addToUFM,addToUFM_C,
+ addListToUFM,addListToUFM_C,
addToUFM_Directly,
addListToUFM_Directly,
- IF_NOT_GHC(addToUFM_C COMMA)
- addListToUFM_C,
delFromUFM,
+ delFromUFM_Directly,
delListFromUFM,
plusUFM,
plusUFM_C,
minusUFM,
intersectUFM,
- IF_NOT_GHC(intersectUFM_C COMMA)
- IF_NOT_GHC(foldUFM COMMA)
+ intersectUFM_C,
+ foldUFM,
mapUFM,
+ elemUFM,
filterUFM,
sizeUFM,
isNullUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
- eltsUFM,
- ufmToList
+ eltsUFM, keysUFM,
+ ufmToList,
+ FastString
) where
-#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
-#endif
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Name ( Name )
-import Unique ( Unique, u2i, mkUniqueGrimily )
+import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
import Util
---import Outputable ( Outputable(..), ExportFlag )
-import Pretty ( Pretty(..), PrettyRep )
-import PprStyle ( PprStyle )
-import SrcLoc ( SrcLoc )
+import GlaExts -- Lots of Int# operations
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
-addToUFM_C :: Uniquable key => (elt -> elt -> elt)
- -> UniqFM elt -> key -> elt -> UniqFM elt
+addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
+ -> UniqFM elt -- old
+ -> key -> elt -- new
+ -> UniqFM elt -- result
+
addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
+elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM_Directly -- when you've got the Unique already
lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
+keysUFM :: UniqFM elt -> [Int] -- Get the keys
eltsUFM :: UniqFM elt -> [elt]
ufmToList :: UniqFM elt -> [(Unique, elt)]
\end{code}
%************************************************************************
\begin{code}
-#if 0
-
-type IdFinMap elt = UniqFM elt
-type TyVarFinMap elt = UniqFM elt
-type NameFinMap elt = UniqFM elt
-type RegFinMap elt = UniqFM elt
+-- Turn off for now, these need to be updated (SDM 4/98)
+#if 0
#ifdef __GLASGOW_HASKELL__
-- I don't think HBC was too happy about this (WDP 94/10)
{-# SPECIALIZE
- unitUFM :: Id -> elt -> IdFinMap elt,
- TyVar -> elt -> TyVarFinMap elt,
- Name -> elt -> NameFinMap elt
- IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- listToUFM :: [(Id, elt)] -> IdFinMap elt,
- [(TyVar,elt)] -> TyVarFinMap elt,
- [(Name, elt)] -> NameFinMap elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt,
- TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
- NameFinMap elt -> Name -> elt -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt,
- TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
- NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- addToUFM_C :: (elt -> elt -> elt)
- -> IdFinMap elt -> Id -> elt -> IdFinMap elt,
- (elt -> elt -> elt)
- -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
- (elt -> elt -> elt)
- -> NameFinMap elt -> Name -> elt -> NameFinMap elt
- IF_NCG(COMMA (elt -> elt -> elt)
- -> RegFinMap elt -> Reg -> elt -> RegFinMap elt)
+ addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
- addListToUFM_C :: (elt -> elt -> elt)
- -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt,
- (elt -> elt -> elt)
- -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
- (elt -> elt -> elt)
- -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
- IF_NCG(COMMA (elt -> elt -> elt)
- -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
+ addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
- delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt,
- TyVarFinMap elt -> TyVar -> TyVarFinMap elt,
- NameFinMap elt -> Name -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt)
+ addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
#-}
{-# SPECIALIZE
- delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt,
- TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt,
- NameFinMap elt -> [Name] -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt)
+ listToUFM :: [(Unique, elt)] -> UniqFM elt
#-}
-
{-# SPECIALIZE
- lookupUFM :: IdFinMap elt -> Id -> Maybe elt,
- TyVarFinMap elt -> TyVar -> Maybe elt,
- NameFinMap elt -> Name -> Maybe elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt)
- #-}
-{-# SPECIALIZE
- lookupWithDefaultUFM
- :: IdFinMap elt -> elt -> Id -> elt,
- TyVarFinMap elt -> elt -> TyVar -> elt,
- NameFinMap elt -> elt -> Name -> elt
- IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt)
+ lookupUFM :: UniqFM elt -> Name -> Maybe elt
+ , UniqFM elt -> Unique -> Maybe elt
#-}
#endif {- __GLASGOW_HASKELL__ -}
-#endif {- 0 -}
+#endif
\end{code}
%************************************************************************
(UniqFM ele)
(UniqFM ele)
-class Uniquable a where
- uniqueOf :: a -> Unique
-
-- for debugging only :-)
{-
instance Text (UniqFM a) where
\begin{code}
emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
+unitUFM key elt = mkLeafUFM (u2i (getUnique key)) elt
unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (u2i (uniqueOf key)) elt
+ = insert_ele combiner fm (u2i (getUnique key)) elt
addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getUnique k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM fm key = delete fm (u2i (getUnique key))
+delFromUFM_Directly fm u = delete fm (u2i u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
--
-- Notice the asymetry of subtraction
--
- minus_trees lf@(LeafUFM i a) t2 =
- case lookup t2 i of
+ minus_trees lf@(LeafUFM i a) t2 =
+ case lookUp t2 i of
Nothing -> lf
Just b -> EmptyUFM
intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
where
intersect_trees (LeafUFM i a) t2 =
- case lookup t2 i of
+ case lookUp t2 i of
Nothing -> EmptyUFM
Just b -> mkLeafUFM i (f a b)
intersect_trees t1 (LeafUFM i a) =
- case lookup t1 i of
+ case lookUp t1 i of
Nothing -> EmptyUFM
Just b -> mkLeafUFM i (f b a)
Now the usual set of `collection' operators, like map, fold, etc.
\begin{code}
-foldUFM fn a EmptyUFM = a
-foldUFM fn a fm = fold_tree fn a fm
+foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
+foldUFM f a (LeafUFM _ obj) = f obj a
+foldUFM f a EmptyUFM = a
+\end{code}
+\begin{code}
mapUFM fn EmptyUFM = EmptyUFM
mapUFM fn fm = map_tree fn fm
Lookup up a binary tree is easy (and fast).
\begin{code}
-lookupUFM fm key = lookup fm (u2i (uniqueOf key))
-lookupUFM_Directly fm key = lookup fm (u2i key)
+elemUFM key fm = case lookUp fm (u2i (getUnique key)) of
+ Nothing -> False
+ Just _ -> True
+
+lookupUFM fm key = lookUp fm (u2i (getUnique key))
+lookupUFM_Directly fm key = lookUp fm (u2i key)
lookupWithDefaultUFM fm deflt key
- = case lookup fm (u2i (uniqueOf key)) of
+ = case lookUp fm (u2i (getUnique key)) of
Nothing -> deflt
Just elt -> elt
lookupWithDefaultUFM_Directly fm deflt key
- = case lookup fm (u2i key) of
+ = case lookUp fm (u2i key) of
Nothing -> deflt
Just elt -> elt
-lookup EmptyUFM _ = Nothing
-lookup fm i = lookup_tree fm
+lookUp EmptyUFM _ = Nothing
+lookUp fm i = lookup_tree fm
where
lookup_tree :: UniqFM a -> Maybe a
folds are *wonderful* things.
\begin{code}
-eltsUFM EmptyUFM = []
-eltsUFM fm = fold_tree (:) [] fm
+eltsUFM fm = foldUFM (:) [] fm
-ufmToList EmptyUFM = []
-ufmToList fm
- = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
- where
- fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
- fold_tree f a (LeafUFM iu obj) = f iu obj a
+ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
+
+keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm
- fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
+fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
+fold_tree f a (LeafUFM iu obj) = f iu obj a
+fold_tree f a EmptyUFM = a
\end{code}
%************************************************************************
(mkLeafUFM i a)
\end{code}
-This has got a left to right ordering.
-\begin{code}
-fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
-fold_tree f a (LeafUFM _ obj) = f obj a
-
-fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
-\end{code}
\begin{code}
map_tree f (NodeUFM j p t1 t2)
filter_tree f lf@(LeafUFM i obj)
| f obj = lf
| otherwise = EmptyUFM
+filter_tree f _ = panic "filter_tree failed"
\end{code}
%************************************************************************
shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
where
- shiftr x y = shiftRA# x y
+ shiftr x y = shiftRL# x y
#else {- not GHC -}
shiftL_ n p = n * (2 ^ p)
#endif {- not GHC -}
\end{code}
-Andy's extras: ToDo: to Util.
-
\begin{code}
-use_fst :: a -> b -> a
-use_fst a b = a
-
use_snd :: a -> b -> b
use_snd a b = b
\end{code}
projects / ghc-hetmet.git / blobdiff