[commit: hoopl] simonmar-hoopl-opt: Remove layers of newtype in Unique and Label (3056dec)
Simon Marlow
marlowsd at gmail.com
Thu Mar 15 14:18:39 CET 2012
Repository : ssh://darcs.haskell.org//srv/darcs/packages/hoopl
On branch : simonmar-hoopl-opt
http://hackage.haskell.org/trac/ghc/changeset/3056dec8fdafe48df1168779528c477c44d30c10
>---------------------------------------------------------------
commit 3056dec8fdafe48df1168779528c477c44d30c10
Author: Simon Marlow <marlowsd at gmail.com>
Date: Thu Mar 15 13:17:30 2012 +0000
Remove layers of newtype in Unique and Label
Improves performance due to eliminating some unnecessary maps in
e.g. mapToList, setToList. This was quite a significant effect in
GHC.
>---------------------------------------------------------------
src/Compiler/Hoopl/Label.hs | 77 +++++------------------------------------
src/Compiler/Hoopl/MkGraph.hs | 4 +-
src/Compiler/Hoopl/Unique.hs | 49 +++++++++++++-------------
3 files changed, 35 insertions(+), 95 deletions(-)
diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs
index e8a7f0b..e8a60ef 100644
--- a/src/Compiler/Hoopl/Label.hs
+++ b/src/Compiler/Hoopl/Label.hs
@@ -22,81 +22,22 @@ import Compiler.Hoopl.Unique
-- Label
-----------------------------------------------------------------------------
-newtype Label = Label { lblToUnique :: Unique }
- deriving (Eq, Ord)
+type Label = Unique
+
+lblToUnique :: Label -> Unique
+lblToUnique = id
uniqueToLbl :: Unique -> Label
-uniqueToLbl = Label
+uniqueToLbl = id
-instance Show Label where
- show (Label n) = "L" ++ show n
+--instance Show Label where
+-- show (Label n) = "L" ++ show n
freshLabel :: UniqueMonad m => m Label
freshLabel = freshUnique >>= return . uniqueToLbl
------------------------------------------------------------------------------
--- LabelSet
-
-newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
-
-instance IsSet LabelSet where
- type ElemOf LabelSet = Label
-
- setNull (LS s) = setNull s
- setSize (LS s) = setSize s
- setMember (Label k) (LS s) = setMember k s
-
- setEmpty = LS setEmpty
- setSingleton (Label k) = LS (setSingleton k)
- setInsert (Label k) (LS s) = LS (setInsert k s)
- setDelete (Label k) (LS s) = LS (setDelete k s)
-
- setUnion (LS x) (LS y) = LS (setUnion x y)
- setDifference (LS x) (LS y) = LS (setDifference x y)
- 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
-
- setElems (LS s) = map uniqueToLbl (setElems s)
- setFromList ks = LS (setFromList (map lblToUnique ks))
-
------------------------------------------------------------------------------
--- LabelMap
-
-newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)
-
-instance IsMap LabelMap where
- type KeyOf LabelMap = Label
-
- mapNull (LM m) = mapNull m
- mapSize (LM m) = mapSize m
- mapMember (Label k) (LM m) = mapMember k m
- mapLookup (Label k) (LM m) = mapLookup k m
- mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
-
- mapEmpty = LM mapEmpty
- mapSingleton (Label k) v = LM (mapSingleton k v)
- mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
- mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
- 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)
- 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)
- mapFold k z (LM m) = mapFold k z m
- mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
-
- mapElems (LM m) = mapElems m
- mapKeys (LM m) = map uniqueToLbl (mapKeys m)
- mapToList (LM m) = [(uniqueToLbl 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])
+type LabelSet = UniqueSet
+type LabelMap v = UniqueMap v
-----------------------------------------------------------------------------
-- FactBase
diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs
index d20a327..58afc87 100644
--- a/src/Compiler/Hoopl/MkGraph.hs
+++ b/src/Compiler/Hoopl/MkGraph.hs
@@ -147,8 +147,8 @@ class Uniques u where
instance Uniques Unique where
withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
-instance Uniques Label where
- withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
+--instance Uniques Label where
+-- withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
-- | Lifts binary 'Graph' functions into 'AGraph' functions.
liftA2 :: (Graph n a b -> Graph n c d -> Graph n e f)
diff --git a/src/Compiler/Hoopl/Unique.hs b/src/Compiler/Hoopl/Unique.hs
index 99c3b45..b69cbee 100644
--- a/src/Compiler/Hoopl/Unique.hs
+++ b/src/Compiler/Hoopl/Unique.hs
@@ -25,14 +25,13 @@ import qualified Data.IntSet as S
-- Unique
-----------------------------------------------------------------------------
-data Unique = Unique { uniqueToInt :: {-# UNPACK #-} !Int }
- deriving (Eq, Ord)
+type Unique = Int
-intToUnique :: Int -> Unique
-intToUnique = Unique
+uniqueToInt :: Unique -> Int
+uniqueToInt = id
-instance Show Unique where
- show (Unique n) = show n
+intToUnique :: Int -> Unique
+intToUnique = id
-----------------------------------------------------------------------------
-- UniqueSet
@@ -44,22 +43,22 @@ instance IsSet UniqueSet where
setNull (US s) = S.null s
setSize (US s) = S.size s
- setMember (Unique k) (US s) = S.member k s
+ setMember k (US s) = S.member k s
setEmpty = US S.empty
- setSingleton (Unique k) = US (S.singleton k)
- setInsert (Unique k) (US s) = US (S.insert k s)
- setDelete (Unique k) (US s) = US (S.delete k s)
+ 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.fold (k . intToUnique) z s
+ setFold k z (US s) = S.fold k z s
- setElems (US s) = map intToUnique (S.elems s)
- setFromList ks = US (S.fromList (map uniqueToInt ks))
+ setElems (US s) = S.elems s
+ setFromList ks = US (S.fromList ks)
-----------------------------------------------------------------------------
-- UniqueMap
@@ -71,15 +70,15 @@ instance IsMap UniqueMap where
mapNull (UM m) = M.null m
mapSize (UM m) = M.size m
- mapMember (Unique k) (UM m) = M.member k m
- mapLookup (Unique k) (UM m) = M.lookup k m
- mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k 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 (Unique k) v = UM (M.singleton k v)
- mapInsert (Unique k) v (UM m) = UM (M.insert k v m)
- mapInsertWith f (Unique k) v (UM m) = UM (M.insertWith f k v m)
- mapDelete (Unique k) (UM m) = UM (M.delete k m)
+ 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)
@@ -93,10 +92,10 @@ instance IsMap UniqueMap where
mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m
mapElems (UM m) = M.elems m
- mapKeys (UM m) = map intToUnique (M.keys m)
- mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]
- mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])
- mapFromListWith f assocs = UM (M.fromListWith f [(uniqueToInt k, v) | (k, v) <- assocs])
+ 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)
----------------------------------------------------------------
-- Monads
@@ -141,4 +140,4 @@ runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a
runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }
allUniques :: [Unique]
-allUniques = map Unique [1..]
+allUniques = [1..]
More information about the Cvs-libraries
mailing list