-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
-%* *
-%************************************************************************
-
-\begin{code}
--- 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
- addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
- #-}
-{-# SPECIALIZE
- listToUFM :: [(Unique, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- lookupUFM :: UniqFM elt -> Name -> Maybe elt
- , UniqFM elt -> Unique -> Maybe elt
- #-}
-
-#endif /* __GLASGOW_HASKELL__ */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Andy Gill's underlying @UniqFM@ machinery}
-%* *
-%************************************************************************
-
-``Uniq Finite maps'' are the heart and soul of the compiler's
-lookup-tables/environments. Important stuff! It works well with
-Dense and Sparse ranges.
-Both @Uq@ Finite maps and @Hash@ Finite Maps
-are built ontop of Int Finite Maps.
-
-This code is explained in the paper:
-\begin{display}
- A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
- "A Cheap balancing act that grows on a tree"
- Glasgow FP Workshop, Sep 1994, pp??-??
-\end{display}
-
-%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ type, and signatures for the functions}
-%* *
-%************************************************************************
-
-@UniqFM a@ is a mapping from Unique to a.
-
-First, the DataType itself; which is either a Node, a Leaf, or an Empty.
-
-\begin{code}
-data UniqFM ele
- = EmptyUFM
- | LeafUFM !FastInt !ele
- | NodeUFM !FastInt -- the switching
- !FastInt -- the delta
- (UniqFM ele)
- (UniqFM ele)
--- INVARIANT: the children of a NodeUFM are never EmptyUFMs
-
-{-
--- for debugging only :-)
-instance Outputable (UniqFM a) where
- ppr(NodeUFM a b t1 t2) =
- sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
- nest 1 (parens (ppr t1)),
- nest 1 (parens (ppr t2))]
- ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
- ppr (EmptyUFM) = empty
--}
--- and when not debugging the package itself...
-instance Outputable a => Outputable (UniqFM a) where
- ppr ufm = ppr (ufmToList ufm)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ functions}
-%* *
-%************************************************************************
-
-First the ways of building a UniqFM.
-
-\begin{code}
-emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (getKeyFastInt (getUnique key)) elt
-unitDirectlyUFM key elt = mkLeafUFM (getKeyFastInt key) elt
-
-listToUFM key_elt_pairs
- = addListToUFM_C use_snd EmptyUFM key_elt_pairs
-
-listToUFM_Directly uniq_elt_pairs
- = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
-\end{code}
-
-Now ways of adding things to UniqFMs.
-
-There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
-but the semantics of this operation demands a linear insertion;
-perhaps the version without the combinator function
-could be optimised using it.
-
-\begin{code}
-addToUFM fm key elt = addToUFM_C use_snd fm key elt
-
-addToUFM_Directly fm u elt = insert_ele use_snd fm (getKeyFastInt u) elt
-
-addToUFM_C combiner fm key elt
- = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt
-
-addToUFM_Acc add unit fm key item
- = insert_ele combiner fm (getKeyFastInt (getUnique key)) (unit item)
- where
- combiner old _unit_item = add item old
-
-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 (getKeyFastInt (getUnique k)) e)
- fm key_elt_pairs
-
-addListToUFM_directly_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Unique,elt)] -> UniqFM elt
-addListToUFM_directly_C combiner fm uniq_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt k) e)
- fm uniq_elt_pairs
-\end{code}
-
-Now ways of removing things from UniqFM.
-
-\begin{code}
-delListFromUFM fm lst = foldl delFromUFM fm lst
-
-delFromUFM fm key = delete fm (getKeyFastInt (getUnique key))
-delFromUFM_Directly fm u = delete fm (getKeyFastInt u)
-
-delete :: UniqFM a -> FastInt -> UniqFM a
-delete EmptyUFM _ = EmptyUFM
-delete fm key = del_ele fm
- where
- del_ele :: UniqFM a -> UniqFM a
-
- del_ele lf@(LeafUFM j _)
- | j ==# key = EmptyUFM
- | otherwise = lf -- no delete!
-
- del_ele (NodeUFM j p t1 t2)
- | j ># key
- = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
- | otherwise
- = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
-
- del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
-\end{code}
-
-Now ways of adding two UniqFM's together.
-
-\begin{code}
-plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
-
-plusUFM_C _ EmptyUFM tr = tr
-plusUFM_C _ tr EmptyUFM = tr
-plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
- where
- mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
- mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
-
- mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = mix_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' (C j j')
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' j j'
- -- / \ / \
- -- t1 t2 t1' t2'
- -- Fast, Ehh !
- --
- mix_branches (NewRoot nd False)
- = mkLLNodeUFM nd left_t right_t
- mix_branches (NewRoot nd True)
- = mkLLNodeUFM nd right_t left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- mix_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (mix_trees t1 t1')
- (mix_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2 + j'
- -- / \
- -- t1' t2'
- mix_branches (LeftRoot Leftt) -- | trace "LL" True
- = mkSLNodeUFM
- (NodeUFMData j p)
- (mix_trees t1 right_t)
- t2
-
- mix_branches (LeftRoot Rightt) -- | trace "LR" True
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (mix_trees t2 right_t)
-
- mix_branches (RightRoot Leftt) -- | trace "RL" True
- = mkSLNodeUFM
- (NodeUFMData j' p')
- (mix_trees left_t t1')
- t2'
-
- mix_branches (RightRoot Rightt) -- | trace "RR" True
- = mkLSNodeUFM
- (NodeUFMData j' p')
- t1'
- (mix_trees left_t t2')
-
- mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
-\end{code}
-
-And ways of subtracting them. First the base cases,
-then the full D&C approach.
-
-\begin{code}
-minusUFM EmptyUFM _ = EmptyUFM
-minusUFM t1 EmptyUFM = t1
-minusUFM fm1 fm2 = minus_trees fm1 fm2
- where
- --
- -- Notice the asymetry of subtraction
- --
- minus_trees lf@(LeafUFM i _a) t2 =
- case lookUp t2 i of
- Nothing -> lf
- Just _ -> EmptyUFM
-
- minus_trees t1 (LeafUFM i _) = delete t1 i
-
- minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = minus_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2
- --
- --
- -- Fast, Ehh !
- --
- minus_branches (NewRoot _ _) = left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- minus_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (minus_trees t1 t1')
- (minus_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- -- again, with asymatry
-
- --
- -- The left is above the right
- --
- minus_branches (LeftRoot Leftt)
- = mkSLNodeUFM
- (NodeUFMData j p)
- (minus_trees t1 right_t)
- t2
- minus_branches (LeftRoot Rightt)
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (minus_trees t2 right_t)
-
- --
- -- The right is above the left
- --
- minus_branches (RightRoot Leftt)
- = minus_trees left_t t1'
- minus_branches (RightRoot Rightt)
- = minus_trees left_t t2'
-
- minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
-\end{code}
-
-And taking the intersection of two UniqFM's.
-
-\begin{code}
-intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
-intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
-
-intersectUFM_C _ EmptyUFM _ = EmptyUFM
-intersectUFM_C _ _ EmptyUFM = EmptyUFM
-intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
- where
- intersect_trees (LeafUFM i a) t2 =
- 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
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f b a)
-
- intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = intersect_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j'
- -- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
- -- Fast, Ehh !
- --
- intersect_branches (NewRoot _nd _) = EmptyUFM
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
- intersect_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (intersect_trees t1 t1')
- (intersect_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' t2 + j'
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1' t2'
- --
- -- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Leftt)
- = intersect_trees t1 right_t
- intersect_branches (LeftRoot Rightt)
- = intersect_trees t2 right_t
- intersect_branches (RightRoot Leftt)
- = intersect_trees left_t t1'
- intersect_branches (RightRoot Rightt)
- = intersect_trees left_t t2'
-
- intersect_trees _ _ = panic ("EmptyUFM found when intersecting trees")
-\end{code}
-
-Now the usual set of `collection' operators, like map, fold, etc.