Permalink
Browse files

switch to IORef

  • Loading branch information...
1 parent d4faea2 commit 4fb78a4353087af584cb123dcdb0ee6ebc4d5e22 @ekmett committed Aug 17, 2011
View
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE MagicHash, TypeFamilies, FlexibleInstances, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Interned.IntSet
@@ -110,13 +110,11 @@ module Data.Interned.IntSet (
) where
import Prelude hiding (lookup,filter,foldr,foldl,null,map)
-import Data.Bits
import qualified Data.List as List
import Data.Monoid (Monoid(..))
import Data.Maybe (fromMaybe)
import Data.Interned.Internal
import Data.Bits
-import Data.Function (on)
import Data.Hashable
import Text.Read
import GHC.Exts ( Word(..), Int(..), shiftRL# )
@@ -176,14 +174,10 @@ tip n = intern (UTip n)
bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
bin _ _ l Nil = l
bin _ _ Nil r = r
---bin p m l r = bin_ p m l r
-bin p m l r
- | m .&. (m - 1) /= 0 = error "illegal mask"
- | otherwise = intern (UBin p m l r)
+bin p m l r = intern (UBin p m l r)
bin_ :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
-bin_ = bin
---bin_ p m l r = intern (UBin p m l r)
+bin_ p m l r = intern (UBin p m l r)
instance Interned IntSet where
type Uninterned IntSet = UninternedIntSet
@@ -820,24 +814,29 @@ withEmpty bars = " ":bars
-- /O(1)/
instance Eq IntSet where
- (==) = (==) `on` identity
+ Nil == Nil = True
+ Tip i _ == Tip j _ = i == j
+ Bin i _ _ _ _ _ == Bin j _ _ _ _ _ = i == j
+ _ == _ = False
{--------------------------------------------------------------------
Ord
NB: this ordering is not the ordering implied by the elements
but is usable for comparison
--------------------------------------------------------------------}
instance Ord IntSet where
- compare = compare `on` identity
+ Nil `compare` Nil = EQ
+ Nil `compare` Tip _ _ = LT
+ Nil `compare` Bin _ _ _ _ _ _ = LT
+ Tip _ _ `compare` Nil = GT
+ Tip i _ `compare` Tip j _ = compare i j
+ Tip i _ `compare` Bin j _ _ _ _ _ = compare i j
+ Bin _ _ _ _ _ _ `compare` Nil = GT
+ Bin i _ _ _ _ _ `compare` Tip j _ = compare i j
+ Bin i _ _ _ _ _ `compare` Bin j _ _ _ _ _ = compare i j
-- compare s1 s2 = compare (toAscList s1) (toAscList s2)
{--------------------------------------------------------------------
- Hashable
---------------------------------------------------------------------}
-instance Hashable IntSet where
- hash = hash . identity
-
-{--------------------------------------------------------------------
Show
--------------------------------------------------------------------}
instance Show IntSet where
View
@@ -22,25 +22,24 @@ import Data.HashMap.Strict (HashMap)
import Data.Foldable
import Data.Traversable
import qualified Data.HashMap.Strict as HashMap
-import Control.Concurrent.MVar
+import Data.IORef
import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)
-import System.Mem.Weak
-- tuning parameter
defaultCacheWidth :: Int
defaultCacheWidth = 1024
data CacheState t = CacheState
{ fresh :: {-# UNPACK #-} !Id
- , content :: !(HashMap (Description t) (Weak t))
+ , content :: !(HashMap (Description t) t)
}
-newtype Cache t = Cache { getCache :: Array Int (MVar (CacheState t)) }
+newtype Cache t = Cache { getCache :: Array Int (IORef (CacheState t)) }
cacheSize :: Cache t -> IO Int
cacheSize (Cache t) = foldrM
(\a b -> do
- v <- readMVar a
+ v <- readIORef a
return $! HashMap.size (content v) + b
) 0 t
@@ -50,14 +49,13 @@ mkCache = result where
w = cacheWidth result
result = Cache
$ unsafePerformIO
- $ traverse newMVar
+ $ traverse newIORef
$ listArray (0,w - 1)
$ replicate w element
type Id = Int
class ( Eq (Description t)
- , Show t -- HACK
, Hashable (Description t)
) => Interned t where
data Description t
@@ -77,32 +75,19 @@ class Interned t => Uninternable t where
unintern :: t -> Uninterned t
intern :: Interned t => Uninterned t -> t
-intern !bt = unsafeDupablePerformIO $ modifyAdvice $ modifyMVar slot go
+intern !bt = unsafeDupablePerformIO $ modifyAdvice $ atomicModifyIORef slot go
where
slot = getCache cache ! r
!dt = describe bt
!hdt = hash dt
!wid = cacheWidth dt
r = hdt `mod` wid
-
go (CacheState i m) = case HashMap.lookup dt m of
- Nothing -> k i m
- Just wt -> do
- mt <- deRefWeak wt
- case mt of
- Just t -> return (CacheState i m, t)
- Nothing -> k i m
- k i m = do let t = identify (wid * i + r) bt
- wt <- t `seq` mkWeakPtr t $ Just remove
- return (CacheState (i + 1) (HashMap.insert dt wt m), t)
- remove = modifyMVar_ slot $
- \ (CacheState i m) -> return $ CacheState i (HashMap.delete dt m)
+ Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (HashMap.insert dt t m), t)
+ Just t -> (CacheState i m, t)
-- given a description, go hunting for an entry in the cache
recover :: Interned t => Description t -> IO (Maybe t)
recover !dt = do
- CacheState _ m <- readMVar $ getCache cache ! (hash dt `mod` cacheWidth dt)
- case HashMap.lookup dt m of
- Nothing -> return Nothing
- Just wt -> deRefWeak wt
-
+ CacheState _ m <- readIORef $ getCache cache ! (hash dt `mod` cacheWidth dt)
+ return $ HashMap.lookup dt m
@@ -8,7 +8,6 @@ import Data.Interned
import Data.ByteString
import Data.ByteString.Char8 as Char8
import Data.Hashable
-import Data.Function (on)
data InternedByteString = InternedByteString
{-# UNPACK #-} !Id
@@ -18,10 +17,10 @@ instance IsString InternedByteString where
fromString = intern . Char8.pack
instance Eq InternedByteString where
- (==) = (==) `on` identity
+ InternedByteString i _ == InternedByteString j _ = i == j
instance Ord InternedByteString where
- compare = compare `on` identity
+ InternedByteString i _ `compare` InternedByteString j _ = i `compare` j
instance Show InternedByteString where
showsPrec d (InternedByteString _ b) = showsPrec d b
@@ -7,7 +7,6 @@ import Data.String
import Data.Interned
import Data.Hashable
import Data.Foldable
-import Data.Function (on)
data InternedString = IS
{-# UNPACK #-} !Id
@@ -17,10 +16,10 @@ instance IsString InternedString where
fromString = intern
instance Eq InternedString where
- (==) = (==) `on` identity
+ IS i _ == IS j _ = i == j
instance Ord InternedString where
- compare = compare `on` identity
+ compare (IS i _) (IS j _) = compare i j
instance Show InternedString where
showsPrec d (IS _ b) = showsPrec d b
@@ -7,7 +7,6 @@ import Data.String
import Data.Interned
import Data.Text
import Data.Hashable
-import Data.Function (on)
data InternedText = InternedText
{-# UNPACK #-} !Id
@@ -17,10 +16,10 @@ instance IsString InternedText where
fromString = intern . pack
instance Eq InternedText where
- (==) = (==) `on` identity
+ InternedText i _ == InternedText j _ = i == j
instance Ord InternedText where
- compare = compare `on` identity
+ compare (InternedText i _) (InternedText j _) = compare i j
instance Show InternedText where
showsPrec d (InternedText _ b) = showsPrec d b
View
@@ -1,6 +1,6 @@
name: intern
category: Data, Data Structures
-version: 0.6
+version: 0.8
license: BSD3
cabal-version: >= 1.6
license-file: LICENSE
@@ -11,6 +11,15 @@ homepage: http://github.com/ekmett/intern/
copyright: Copyright (C) 2011 Edward A. Kmett
synopsis: Efficient hash-consing for arbitrary data types
description:
+ Changes from 0.7 to 0.8
+ .
+ * Disabled cache removal as it was causing problems on large data sets. There is no good way to ensure that both references remain alive long enough to finish comparisons.
+ * Switched to IORef from MVar
+ .
+ Changes from 0.6 to 0.7
+ .
+ * Fixed problem where comparisons could happen between data structures while one was still a thunk, leading to equal structures comparing as inequal in limited circumstances, by appropriately using strictness annotations.
+ .
Efficient hash-consing for arbitrary data types
.
Changes from 0.5.2 to 0.6

0 comments on commit 4fb78a4

Please sign in to comment.