Remove layers of newtype in Unique and Label simonmar-hoopl-opt
authorSimon Marlow <marlowsd@gmail.com>
Thu, 15 Mar 2012 13:17:30 +0000 (13:17 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Thu, 15 Mar 2012 13:17:30 +0000 (13:17 +0000)
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
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/Unique.hs

index e8a7f0b..e8a60ef 100644 (file)
@@ -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
index d20a327..58afc87 100644 (file)
@@ -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)
index 99c3b45..b69cbee 100644 (file)
@@ -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..]