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 <[email protected]> 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..] _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
