diff options
| -rw-r--r-- | compiler/cmm/BlockId.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/Hoopl/Collections.hs | 71 | ||||
| -rw-r--r-- | compiler/cmm/Hoopl/Label.hs | 25 | ||||
| -rw-r--r-- | compiler/cmm/Hoopl/Unique.hs | 93 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
5 files changed, 85 insertions, 110 deletions
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index 73de69efcf..4f4e0e8c53 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -16,8 +16,7 @@ import Name import Unique import UniqSupply -import Hoopl.Label (Label, uniqueToLbl) -import Hoopl.Unique (intToUnique) +import Hoopl.Label (Label, mkHooplLabel) ---------------------------------------------------------------- --- Block Ids, their environments, and their sets @@ -34,7 +33,7 @@ compilation unit in which it appears. type BlockId = Label mkBlockId :: Unique -> BlockId -mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique +mkBlockId unique = mkHooplLabel $ getKey unique newBlockId :: MonadUnique m => m BlockId newBlockId = mkBlockId <$> getUniqueM diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs index be28849b60..9bccc665fa 100644 --- a/compiler/cmm/Hoopl/Collections.hs +++ b/compiler/cmm/Hoopl/Collections.hs @@ -1,13 +1,20 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE TypeFamilies #-} module Hoopl.Collections ( IsSet(..) , setInsertList, setDeleteList, setUnions , IsMap(..) , mapInsertList, mapDeleteList, mapUnions + , UniqueMap, UniqueSet ) where import GhcPrelude +import qualified Data.IntMap as M +import qualified Data.IntSet as S + import Data.List (foldl', foldl1') class IsSet set where @@ -87,3 +94,67 @@ mapDeleteList keys map = foldl' (flip mapDelete) map keys mapUnions :: IsMap map => [map a] -> map a mapUnions [] = mapEmpty mapUnions maps = foldl1' mapUnion maps + +----------------------------------------------------------------------------- +-- Basic instances +----------------------------------------------------------------------------- + +newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) + +instance IsSet UniqueSet where + type ElemOf UniqueSet = Int + + setNull (US s) = S.null s + setSize (US s) = S.size s + setMember k (US s) = S.member k s + + setEmpty = US S.empty + setSingleton k = US (S.singleton k) + setInsert k (US s) = US (S.insert k s) + setDelete k (US s) = US (S.delete k s) + + setUnion (US x) (US y) = US (S.union x y) + setDifference (US x) (US y) = US (S.difference x y) + setIntersection (US x) (US y) = US (S.intersection x y) + setIsSubsetOf (US x) (US y) = S.isSubsetOf x y + + setFold k z (US s) = S.foldr k z s + + setElems (US s) = S.elems s + setFromList ks = US (S.fromList ks) + +newtype UniqueMap v = UM (M.IntMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsMap UniqueMap where + type KeyOf UniqueMap = Int + + mapNull (UM m) = M.null m + mapSize (UM m) = M.size m + mapMember k (UM m) = M.member k m + mapLookup k (UM m) = M.lookup k m + mapFindWithDefault def k (UM m) = M.findWithDefault def k m + + mapEmpty = UM M.empty + mapSingleton k v = UM (M.singleton k v) + mapInsert k v (UM m) = UM (M.insert k v m) + mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) + mapDelete k (UM m) = UM (M.delete k m) + + mapUnion (UM x) (UM y) = UM (M.union x y) + mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y) + mapDifference (UM x) (UM y) = UM (M.difference x y) + mapIntersection (UM x) (UM y) = UM (M.intersection x y) + mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y + + mapMap f (UM m) = UM (M.map f m) + mapMapWithKey f (UM m) = UM (M.mapWithKey f m) + mapFold k z (UM m) = M.foldr k z m + mapFoldWithKey k z (UM m) = M.foldrWithKey k z m + mapFilter f (UM m) = UM (M.filter f m) + + mapElems (UM m) = M.elems m + mapKeys (UM m) = M.keys m + mapToList (UM m) = M.toList m + mapFromList assocs = UM (M.fromList assocs) + mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs index e28f92b6b9..ddf200aa73 100644 --- a/compiler/cmm/Hoopl/Label.hs +++ b/compiler/cmm/Hoopl/Label.hs @@ -8,16 +8,15 @@ module Hoopl.Label , LabelSet , FactBase , lookupFact - , uniqueToLbl + , mkHooplLabel ) where import GhcPrelude import Outputable -import Hoopl.Collections -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} -import Hoopl.Unique +import Hoopl.Collections import Unique (Uniquable(..)) @@ -25,11 +24,11 @@ import Unique (Uniquable(..)) -- Label ----------------------------------------------------------------------------- -newtype Label = Label { lblToUnique :: Unique } +newtype Label = Label { lblToUnique :: Int } deriving (Eq, Ord) -uniqueToLbl :: Unique -> Label -uniqueToLbl = Label +mkHooplLabel :: Int -> Label +mkHooplLabel = Label instance Show Label where show (Label n) = "L" ++ show n @@ -62,9 +61,9 @@ instance IsSet LabelSet where setIntersection (LS x) (LS y) = LS (setIntersection x y) setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y - setFold k z (LS s) = setFold (k . uniqueToLbl) z s + setFold k z (LS s) = setFold (k . mkHooplLabel) z s - setElems (LS s) = map uniqueToLbl (setElems s) + setElems (LS s) = map mkHooplLabel (setElems s) setFromList ks = LS (setFromList (map lblToUnique ks)) ----------------------------------------------------------------------------- @@ -89,20 +88,20 @@ instance IsMap LabelMap where mapDelete (Label k) (LM m) = LM (mapDelete k m) mapUnion (LM x) (LM y) = LM (mapUnion x y) - mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) + mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y) mapDifference (LM x) (LM y) = LM (mapDifference x y) mapIntersection (LM x) (LM y) = LM (mapIntersection x y) mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y mapMap f (LM m) = LM (mapMap f m) - mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) + mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m) mapFold k z (LM m) = mapFold k z m - mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m + mapFoldWithKey k z (LM m) = mapFoldWithKey (k . mkHooplLabel) z m mapFilter f (LM m) = LM (mapFilter f m) mapElems (LM m) = mapElems m - mapKeys (LM m) = map uniqueToLbl (mapKeys m) - mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m] + mapKeys (LM m) = map mkHooplLabel (mapKeys m) + mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m] mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) diff --git a/compiler/cmm/Hoopl/Unique.hs b/compiler/cmm/Hoopl/Unique.hs deleted file mode 100644 index f6fff985e2..0000000000 --- a/compiler/cmm/Hoopl/Unique.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE TypeFamilies #-} -module Hoopl.Unique - ( Unique - , UniqueMap - , UniqueSet - , intToUnique - ) where - -import GhcPrelude - -import qualified Data.IntMap as M -import qualified Data.IntSet as S - -import Hoopl.Collections - - ------------------------------------------------------------------------------ --- Unique ------------------------------------------------------------------------------ - -type Unique = Int - -intToUnique :: Int -> Unique -intToUnique = id - ------------------------------------------------------------------------------ --- UniqueSet - -newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) - -instance IsSet UniqueSet where - type ElemOf UniqueSet = Unique - - setNull (US s) = S.null s - setSize (US s) = S.size s - setMember k (US s) = S.member k s - - setEmpty = US S.empty - setSingleton k = US (S.singleton k) - setInsert k (US s) = US (S.insert k s) - setDelete k (US s) = US (S.delete k s) - - setUnion (US x) (US y) = US (S.union x y) - setDifference (US x) (US y) = US (S.difference x y) - setIntersection (US x) (US y) = US (S.intersection x y) - setIsSubsetOf (US x) (US y) = S.isSubsetOf x y - - setFold k z (US s) = S.foldr k z s - - setElems (US s) = S.elems s - setFromList ks = US (S.fromList ks) - ------------------------------------------------------------------------------ --- UniqueMap - -newtype UniqueMap v = UM (M.IntMap v) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -instance IsMap UniqueMap where - type KeyOf UniqueMap = Unique - - mapNull (UM m) = M.null m - mapSize (UM m) = M.size m - mapMember k (UM m) = M.member k m - mapLookup k (UM m) = M.lookup k m - mapFindWithDefault def k (UM m) = M.findWithDefault def k m - - mapEmpty = UM M.empty - mapSingleton k v = UM (M.singleton k v) - mapInsert k v (UM m) = UM (M.insert k v m) - mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) - mapDelete k (UM m) = UM (M.delete k m) - - mapUnion (UM x) (UM y) = UM (M.union x y) - mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) - mapDifference (UM x) (UM y) = UM (M.difference x y) - mapIntersection (UM x) (UM y) = UM (M.intersection x y) - mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y - - mapMap f (UM m) = UM (M.map f m) - mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) - mapFold k z (UM m) = M.foldr k z m - mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m - mapFilter f (UM m) = UM (M.filter f m) - - mapElems (UM m) = M.elems m - mapKeys (UM m) = M.keys m - mapToList (UM m) = M.toList m - mapFromList assocs = UM (M.fromList assocs) - mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index d4387cbab0..d6d55bf01e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -564,7 +564,6 @@ Library Hoopl.Dataflow Hoopl.Graph Hoopl.Label - Hoopl.Unique -- CgInfoTbls used in ghci/DebuggerUtils -- CgHeapery mkVirtHeapOffsets used in ghci |