%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
Based on @FiniteMaps@ (as you would expect).
-Basically, the things need to be in class @NamedThing@, and we use the
-@getTheUnique@ method to grab their @Uniques@.
+Basically, the things need to be in class @Uniquable@, and we use the
+@uniqueOf@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
-@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations
-of this stuff for Ids and TyVars, respectively.
-
\begin{code}
#if defined(COMPILING_GHC)
#include "HsVersions.h"
module UniqFM (
UniqFM, -- abstract type
+ Uniquable(..), -- class to go with it
emptyUFM,
- singletonUFM,
- singletonDirectlyUFM,
+ unitUFM,
+ unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
addToUFM,
- IF_NOT_GHC(addListToUFM COMMA)
+ addListToUFM,
addToUFM_Directly,
+ addListToUFM_Directly,
IF_NOT_GHC(addToUFM_C COMMA)
- IF_NOT_GHC(addListToUFM_C COMMA)
+ addListToUFM_C,
delFromUFM,
+ delFromUFM_Directly,
delListFromUFM,
plusUFM,
plusUFM_C,
filterUFM,
sizeUFM,
isNullUFM,
- lookupUFM,
- lookupDirectlyUFM,
- IF_NOT_GHC(lookupWithDefaultUFM COMMA)
+ lookupUFM, lookupUFM_Directly,
+ lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM,
- ufmToList,
-
- -- to make the interface self-sufficient
- Id, TyVar, Unique
- IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling
+ ufmToList
) where
-import AbsUniType -- for specialisation to TyVars
-import Id -- for specialisation to Ids
-import IdInfo -- sigh
-import Maybes ( maybeToBool, Maybe(..) )
-import Name
-import Outputable
-import Unique ( u2i, mkUniqueGrimily, Unique )
+#if defined(COMPILING_GHC)
+IMP_Ubiq(){-uitous-}
+#endif
+
+import Unique ( Unique, u2i, mkUniqueGrimily )
import Util
+import Pretty ( SYN_IE(Pretty), PrettyRep )
+import PprStyle ( PprStyle )
+import SrcLoc ( SrcLoc )
+
#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
#define IF_NCG(a) a
#else
#define IF_NCG(a) {--}
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
isNullUFM :: UniqFM elt -> Bool
-singletonUFM :: NamedThing key => key -> elt -> UniqFM elt
-singletonDirectlyUFM -- got the Unique already
+unitUFM :: Uniquable key => key -> elt -> UniqFM elt
+unitDirectlyUFM -- got the Unique already
:: Unique -> elt -> UniqFM elt
-listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
+listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
listToUFM_Directly
:: [(Unique, elt)] -> UniqFM elt
-addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
+addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
-addToUFM_C :: NamedThing key => (elt -> elt -> elt)
+addToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM_C :: NamedThing key => (elt -> elt -> elt)
+addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
-delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt
-delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> 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
sizeUFM :: UniqFM elt -> Int
-lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
-lookupDirectlyUFM -- when you've got the Unique already
+lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
+lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
lookupWithDefaultUFM
- :: NamedThing key => UniqFM elt -> elt -> key -> elt
+ :: Uniquable key => UniqFM elt -> elt -> key -> elt
+lookupWithDefaultUFM_Directly
+ :: UniqFM elt -> elt -> Unique -> elt
eltsUFM :: UniqFM elt -> [elt]
ufmToList :: UniqFM elt -> [(Unique, elt)]
%************************************************************************
\begin{code}
-type IdFinMap elt = UniqFM elt
-type TyVarFinMap elt = UniqFM elt
-type NameFinMap elt = UniqFM elt
-type RegFinMap elt = UniqFM elt
-\end{code}
-
-\begin{code}
#ifdef __GLASGOW_HASKELL__
-- I don't think HBC was too happy about this (WDP 94/10)
{-# SPECIALIZE
- singletonUFM :: 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)
+ addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
+ , UniqFM elt -> [(RnName, elt)] -> UniqFM 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)
+ addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
+ , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM 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)
+ addToUFM :: UniqFM elt -> Unique -> 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)
+ listToUFM :: [(Unique, elt)] -> UniqFM elt
+ , [(RnName, 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)
+ lookupUFM :: UniqFM elt -> Name -> Maybe elt
+ , UniqFM elt -> RnName -> Maybe elt
+ , UniqFM elt -> Unique -> Maybe 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)
- #-}
-
-{-# 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)
+ lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt
#-}
#endif {- __GLASGOW_HASKELL__ -}
(UniqFM ele)
(UniqFM ele)
+class Uniquable a where
+ uniqueOf :: a -> Unique
+
-- for debugging only :-)
{-
instance Text (UniqFM a) where
\begin{code}
emptyUFM = EmptyUFM
-singletonUFM key elt = mkLeafUFM (u2i (getTheUnique key)) elt
-singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
+unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
+unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
= addListToUFM_C use_snd EmptyUFM 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 (getTheUnique key)) elt
+ = insert_ele combiner fm (u2i (uniqueOf 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 (getTheUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf 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 (getTheUnique key))
+delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM_Directly fm u = delete fm (u2i u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
del_ele nd@(NodeUFM j p t1 t2)
| j _GT_ key
= mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
- | otherwise
+ | otherwise
= mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
mix_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(mix_trees t1 t1')
-- t1 t2 t1' t2' t1 t2 + j'
-- / \
-- t1' t2'
- mix_branches (LeftRoot Left) -- | trace "LL" True
+ mix_branches (LeftRoot Leftt) -- | trace "LL" True
= mkSLNodeUFM
(NodeUFMData j p)
- (mix_trees t1 right_t)
+ (mix_trees t1 right_t)
t2
- mix_branches (LeftRoot Right) -- | trace "LR" True
+ mix_branches (LeftRoot Rightt) -- | trace "LR" True
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (mix_trees t2 right_t)
+ (mix_trees t2 right_t)
- mix_branches (RightRoot Left) -- | trace "RL" True
+ mix_branches (RightRoot Leftt) -- | trace "RL" True
= mkSLNodeUFM
(NodeUFMData j' p')
- (mix_trees left_t t1')
+ (mix_trees left_t t1')
t2'
- mix_branches (RightRoot Right) -- | trace "RR" True
+ mix_branches (RightRoot Rightt) -- | trace "RR" True
= mkLSNodeUFM
(NodeUFMData j' p')
t1'
- (mix_trees left_t t2')
+ (mix_trees left_t t2')
mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
\end{code}
--
-- 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
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 t2
- --
- --
+ --
+ --
-- Fast, Ehh !
--
minus_branches (NewRoot nd _) = left_t
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
minus_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(minus_trees t1 t1')
--
-- The left is above the right
--
- minus_branches (LeftRoot Left)
+ minus_branches (LeftRoot Leftt)
= mkSLNodeUFM
(NodeUFMData j p)
- (minus_trees t1 right_t)
+ (minus_trees t1 right_t)
t2
- minus_branches (LeftRoot Right)
+ minus_branches (LeftRoot Rightt)
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (minus_trees t2 right_t)
+ (minus_trees t2 right_t)
--
-- The right is above the left
--
- minus_branches (RightRoot Left)
+ minus_branches (RightRoot Leftt)
= minus_trees left_t t1'
- minus_branches (RightRoot Right)
+ minus_branches (RightRoot Rightt)
= minus_trees left_t t2'
minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
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)
where
-- Given a disjoint j,j' (p >^ p' && p' >^ p):
--
- -- j j'
+ -- j j'
-- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
+ -- t1 t2 t1' t2'
+ --
-- Fast, Ehh !
--
intersect_branches (NewRoot nd _) = EmptyUFM
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
+ --
intersect_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(intersect_trees t1 t1')
-- j j' t2 + j'
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1' t2'
- --
+ --
-- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Left)
+
+ intersect_branches (LeftRoot Leftt)
= intersect_trees t1 right_t
- intersect_branches (LeftRoot Right)
+ intersect_branches (LeftRoot Rightt)
= intersect_trees t2 right_t
- intersect_branches (RightRoot Left)
+ intersect_branches (RightRoot Leftt)
= intersect_trees left_t t1'
- intersect_branches (RightRoot Right)
+ intersect_branches (RightRoot Rightt)
= intersect_trees left_t t2'
intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
Lookup up a binary tree is easy (and fast).
\begin{code}
-lookupUFM fm key = lookup fm (u2i (getTheUnique key))
-lookupDirectlyUFM fm key = lookup fm (u2i key)
+lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
+lookupUFM_Directly fm key = lookUp fm (u2i key)
lookupWithDefaultUFM fm deflt key
- = case lookup fm (u2i (getTheUnique key)) of
+ = case lookUp fm (u2i (uniqueOf key)) of
+ Nothing -> deflt
+ Just elt -> elt
+
+lookupWithDefaultUFM_Directly fm deflt key
+ = 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
filter_tree f nd@(NodeUFM j p t1 t2)
= mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
-filter_tree f lf@(LeafUFM i obj)
+filter_tree f lf@(LeafUFM i obj)
| f obj = lf
| otherwise = EmptyUFM
\end{code}
This is the information used when computing new NodeUFMs.
\begin{code}
-data Side = Left | Right
+data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
data CommonRoot
= LeftRoot Side -- which side is the right down ?
| RightRoot Side -- which side is the left down ?
| otherwise -> NewRoot nd (j _GT_ j2)
where
decideSide :: Bool -> Side
- decideSide True = Left
- decideSide False = Right
+ decideSide True = Leftt
+ decideSide False = Rightt
\end{code}
This might be better in Util.lhs ?
{-# INLINE shiftR_ #-}
shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
-# if __GLASGOW_HASKELL__ >= 23
where
shiftr x y = shiftRA# x y
-# else
- shiftr x y = shiftR# x y
-# endif
#else {- not GHC -}
shiftL_ n p = n * (2 ^ p)
projects / ghc-hetmet.git / blobdiff