Put back the newtype around Label
authorSimon Marlow <marlowsd@gmail.com>
Fri, 6 Jul 2012 13:31:24 +0000 (14:31 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 6 Jul 2012 15:04:31 +0000 (16:04 +0100)
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
src/Compiler/Hoopl/MkGraph.hs

index e8a60ef..e8a7f0b 100644 (file)
@@ -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
index 769b28b..a78f46d 100644 (file)
@@ -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)