Repository : ssh://darcs.haskell.org//srv/darcs/packages/hoopl On branch : master
http://hackage.haskell.org/trac/ghc/changeset/5ee8f3665e13e0f9baac8943d8deb207c2453604 >--------------------------------------------------------------- commit 5ee8f3665e13e0f9baac8943d8deb207c2453604 Author: Simon Marlow <[email protected]> Date: Fri Jul 6 14:31:24 2012 +0100 Put back the newtype around Label It was a pain having Label==Int, because we can't make Label-specific instances for things. The performance drop doesn't seem significant. >--------------------------------------------------------------- src/Compiler/Hoopl/Label.hs | 77 ++++++++++++++++++++++++++++++++++++----- src/Compiler/Hoopl/MkGraph.hs | 6 ++-- 2 files changed, 71 insertions(+), 12 deletions(-) diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs index e8a60ef..e8a7f0b 100644 --- a/src/Compiler/Hoopl/Label.hs +++ b/src/Compiler/Hoopl/Label.hs @@ -22,22 +22,81 @@ import Compiler.Hoopl.Unique -- Label ----------------------------------------------------------------------------- -type Label = Unique - -lblToUnique :: Label -> Unique -lblToUnique = id +newtype Label = Label { lblToUnique :: Unique } + deriving (Eq, Ord) uniqueToLbl :: Unique -> Label -uniqueToLbl = id +uniqueToLbl = Label ---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 -type LabelSet = UniqueSet -type LabelMap v = UniqueMap v +----------------------------------------------------------------------------- +-- 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]) ----------------------------------------------------------------------------- -- FactBase diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs index 769b28b..a78f46d 100644 --- a/src/Compiler/Hoopl/MkGraph.hs +++ b/src/Compiler/Hoopl/MkGraph.hs @@ -14,7 +14,7 @@ module Compiler.Hoopl.MkGraph ) where -import Compiler.Hoopl.Label (Label) +import Compiler.Hoopl.Label (Label, uniqueToLbl) import Compiler.Hoopl.Block import Compiler.Hoopl.Graph as U import Compiler.Hoopl.Unique @@ -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) _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
