From 68bc57c179fe4f1d739a435766bced7236b36261 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 6 Feb 2008 14:16:20 +0000 Subject: [PATCH] Make UniqFM strict in its elements --- compiler/basicTypes/NameEnv.lhs | 2 +- compiler/basicTypes/VarEnv.lhs | 2 +- compiler/utils/LazyUniqFM.lhs | 340 +++++++++++++++++++++++++++++++++++++++ compiler/utils/UniqFM.lhs | 4 +- 4 files changed, 344 insertions(+), 4 deletions(-) create mode 100644 compiler/utils/LazyUniqFM.lhs diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs index b6a7ec8..5dd2bb2 100644 --- a/compiler/basicTypes/NameEnv.lhs +++ b/compiler/basicTypes/NameEnv.lhs @@ -27,7 +27,7 @@ module NameEnv ( import Name import Unique(Unique) -import UniqFM +import LazyUniqFM import Maybes import Outputable \end{code} diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index d65ec5f..3b0be0b 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -46,7 +46,7 @@ module VarEnv ( import OccName import Var import VarSet -import UniqFM +import UniqFM import Unique import Util import Maybes diff --git a/compiler/utils/LazyUniqFM.lhs b/compiler/utils/LazyUniqFM.lhs new file mode 100644 index 0000000..d8132e3 --- /dev/null +++ b/compiler/utils/LazyUniqFM.lhs @@ -0,0 +1,340 @@ +% +% (c) The University of Glasgow 2006 +% (c) The AQUA Project, Glasgow University, 1994-1998 +% + +LazyUniqFM: Specialised lazy finite maps, for things with @Uniques@ + +Based on @UniqFM@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +\begin{code} +{-# OPTIONS -Wall -fno-warn-name-shadowing -Werror -fallow-undecidable-instances #-} +module LazyUniqFM ( + UniqFM, -- abstract type + + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + plusUFM, + plusUFM_C, + minusUFM, + intersectsUFM, + intersectUFM, + intersectUFM_C, + foldUFM, foldUFM_Directly, + mapUFM, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, + sizeUFM, + hashUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + eltsUFM, keysUFM, + ufmToList + ) where + +import qualified UniqFM as S + +import Unique +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''. + +\begin{code} +emptyUFM :: UniqFM elt +isNullUFM :: UniqFM elt -> Bool +unitUFM :: Uniquable key => key -> elt -> UniqFM elt +unitDirectlyUFM -- got the Unique already + :: Unique -> elt -> UniqFM elt +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt +listToUFM_Directly + :: [(Unique, elt)] -> UniqFM elt + +addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt +addToUFM_Directly + :: UniqFM elt -> Unique -> elt -> UniqFM elt + +addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM elt -- old + -> key -> elt -- new + -> UniqFM elt -- result + +addToUFM_Acc :: Uniquable key => + (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- 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 + +plusUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt + +minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 + +intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +intersectUFM_C :: (elt1 -> elt2 -> elt3) + -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3 +intersectsUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool + +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt + +sizeUFM :: UniqFM elt -> Int +hashUFM :: UniqFM elt -> Int +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool +elemUFM_Directly:: Unique -> UniqFM elt -> Bool + +lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt +lookupUFM_Directly -- when you've got the Unique already + :: UniqFM elt -> Unique -> Maybe elt +lookupWithDefaultUFM + :: Uniquable key => UniqFM elt -> elt -> key -> elt +lookupWithDefaultUFM_Directly + :: UniqFM elt -> elt -> Unique -> elt + +keysUFM :: UniqFM elt -> [Unique] -- Get the keys +eltsUFM :: UniqFM elt -> [elt] +ufmToList :: UniqFM elt -> [(Unique, elt)] +\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} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +@UniqFM a@ is a mapping from Unique to a. + +\begin{code} +data Lazy a = Lazy { fromLazy :: a } + +newtype UniqFM ele = MkUniqFM (S.UniqFM (Lazy ele)) + +instance Outputable (S.UniqFM (Lazy a)) => Outputable (UniqFM a) where + ppr (MkUniqFM fm) = ppr fm + +instance Outputable a => Outputable (Lazy a) where + ppr (Lazy x) = ppr x +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ functions} +%* * +%************************************************************************ + +First the ways of building a UniqFM. + +\begin{code} +emptyUFM = MkUniqFM $ S.EmptyUFM +unitUFM key elt = MkUniqFM $ S.unitUFM key (Lazy elt) +unitDirectlyUFM key elt = MkUniqFM $ S.unitDirectlyUFM key (Lazy elt) + +listToUFM key_elt_pairs + = MkUniqFM $ S.listToUFM [ (k, Lazy v) | (k, v) <- key_elt_pairs ] +listToUFM_Directly uniq_elt_pairs + = MkUniqFM + $ S.listToUFM_Directly [ (k, Lazy v) | (k, v) <- 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 (MkUniqFM fm) key elt = MkUniqFM $ S.addToUFM fm key (Lazy elt) + +addToUFM_Directly (MkUniqFM fm) u elt + = MkUniqFM $ S.addToUFM_Directly fm u (Lazy elt) + +addToUFM_C combiner (MkUniqFM fm) key elt + = MkUniqFM $ S.addToUFM_C combiner' fm key (Lazy elt) + where combiner' (Lazy l) (Lazy r) = Lazy (combiner l r) + +addToUFM_Acc add unit (MkUniqFM fm) key item + = MkUniqFM $ S.addToUFM_Acc add' unit' fm key item + where add' elt (Lazy elts) = Lazy (add elt elts) + unit' elt = Lazy (unit elt) + +addListToUFM (MkUniqFM fm) key_elt_pairs + = MkUniqFM $ S.addListToUFM fm [ (k, Lazy v) | (k, v) <- key_elt_pairs ] +addListToUFM_Directly (MkUniqFM fm) uniq_elt_pairs + = MkUniqFM + $ S.addListToUFM_Directly fm [ (k, Lazy v) | (k, v) <- uniq_elt_pairs ] + +addListToUFM_C combiner (MkUniqFM fm) key_elt_pairs + = MkUniqFM + $ S.addListToUFM_C combiner' fm [ (k, Lazy v) | (k, v) <- key_elt_pairs ] + where combiner' (Lazy l) (Lazy r) = Lazy (combiner l r) +\end{code} + +Now ways of removing things from UniqFM. + +\begin{code} +delListFromUFM (MkUniqFM fm) lst = MkUniqFM $ S.delListFromUFM fm lst + +delFromUFM (MkUniqFM fm) key = MkUniqFM $ S.delFromUFM fm key +delFromUFM_Directly (MkUniqFM fm) u = MkUniqFM $ S.delFromUFM_Directly fm u +\end{code} + +Now ways of adding two UniqFM's together. + +\begin{code} +plusUFM (MkUniqFM tr1) (MkUniqFM tr2) = MkUniqFM $ S.plusUFM tr1 tr2 + +plusUFM_C f (MkUniqFM tr1) (MkUniqFM tr2) = MkUniqFM $ S.plusUFM_C f' tr1 tr2 + where f' (Lazy l) (Lazy r) = Lazy $ f l r +\end{code} + +And ways of subtracting them. First the base cases, +then the full D&C approach. + +\begin{code} +minusUFM (MkUniqFM fm1) (MkUniqFM fm2) = MkUniqFM $ S.minusUFM fm1 fm2 +\end{code} + +And taking the intersection of two UniqFM's. + +\begin{code} +intersectUFM (MkUniqFM t1) (MkUniqFM t2) = MkUniqFM $ S.intersectUFM t1 t2 +intersectsUFM (MkUniqFM t1) (MkUniqFM t2) = S.intersectsUFM t1 t2 + +intersectUFM_C f (MkUniqFM fm1) (MkUniqFM fm2) + = MkUniqFM $ S.intersectUFM_C f' fm1 fm2 + where f' (Lazy l) (Lazy r) = Lazy $ f l r +\end{code} + +Now the usual set of `collection' operators, like map, fold, etc. + +\begin{code} +foldUFM f a (MkUniqFM ufm) = S.foldUFM f' a ufm + where f' (Lazy elt) x = f elt x +\end{code} + +\begin{code} +mapUFM fn (MkUniqFM fm) = MkUniqFM (S.mapUFM fn' fm) + where fn' (Lazy elt) = Lazy (fn elt) + +filterUFM fn (MkUniqFM fm) = MkUniqFM (S.filterUFM fn' fm) + where fn' (Lazy elt) = fn elt + +filterUFM_Directly fn (MkUniqFM fm) = MkUniqFM $ S.filterUFM_Directly fn' fm + where fn' u (Lazy elt) = fn u elt +\end{code} + +Note, this takes a long time, O(n), but +because we dont want to do this very often, we put up with this. +O'rable, but how often do we look at the size of +a finite map? + +\begin{code} +sizeUFM (MkUniqFM fm) = S.sizeUFM fm + +isNullUFM (MkUniqFM fm) = S.isNullUFM fm + +-- hashing is used in VarSet.uniqAway, and should be fast +-- We use a cheap and cheerful method for now +hashUFM (MkUniqFM fm) = S.hashUFM fm +\end{code} + +looking up in a hurry is the {\em whole point} of this binary tree lark. +Lookup up a binary tree is easy (and fast). + +\begin{code} +elemUFM key (MkUniqFM fm) = S.elemUFM key fm +elemUFM_Directly key (MkUniqFM fm) = S.elemUFM_Directly key fm + +lookupUFM (MkUniqFM fm) key = fmap fromLazy $ S.lookupUFM fm key +lookupUFM_Directly (MkUniqFM fm) key + = fmap fromLazy $ S.lookupUFM_Directly fm key + +lookupWithDefaultUFM (MkUniqFM fm) deflt key + = fromLazy $ S.lookupWithDefaultUFM fm (Lazy deflt) key + +lookupWithDefaultUFM_Directly (MkUniqFM fm) deflt key + = fromLazy $ S.lookupWithDefaultUFM_Directly fm (Lazy deflt) key +\end{code} + +folds are *wonderful* things. + +\begin{code} +eltsUFM (MkUniqFM fm) = map fromLazy $ S.eltsUFM fm +keysUFM (MkUniqFM fm) = S.keysUFM fm +ufmToList (MkUniqFM fm) = [ (k, v) | (k, Lazy v) <- S.ufmToList fm ] +foldUFM_Directly f elt (MkUniqFM fm) + = S.foldUFM_Directly f' elt fm + where f' u (Lazy elt') x = f u elt' x +\end{code} + diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 5b014ca..57295d5 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -203,7 +203,7 @@ First, the DataType itself; which is either a Node, a Leaf, or an Empty. \begin{code} data UniqFM ele = EmptyUFM - | LeafUFM !FastInt ele + | LeafUFM !FastInt !ele | NodeUFM !FastInt -- the switching !FastInt -- the delta (UniqFM ele) @@ -698,7 +698,7 @@ insert_ele f (LeafUFM j old) i new (indexToRoot j)) (mkLeafUFM i new) (mkLeafUFM j old) - | j ==# i = mkLeafUFM j $! f old new + | j ==# i = mkLeafUFM j $ f old new | otherwise = mkLLNodeUFM (getCommonNodeUFMData (indexToRoot i) -- 1.7.10.4