Permalink
Browse files

improved the latency of cache access dramatically by removing the sin…

…gle choke point
  • Loading branch information...
1 parent 6c9e511 commit 8b8dbd2d75838b90773eed6c882d7281c3fa3657 @ekmett committed Aug 13, 2011
Showing with 40 additions and 14 deletions.
  1. +2 −1 Data/Interned/IntSet.hs
  2. +36 −12 Data/Interned/Internal.hs
  3. +2 −1 intern.cabal
View
@@ -114,7 +114,7 @@ import Data.Bits
import qualified Data.List as List
import Data.Monoid (Monoid(..))
import Data.Maybe (fromMaybe)
-import Data.Interned
+import Data.Interned.Internal
import Data.Function (on)
import Data.Hashable
import Text.Read
@@ -184,6 +184,7 @@ instance Interned IntSet where
identity Nil = 0
identity (Tip i _) = i
identity (Bin i _ _ _ _ _) = i
+ cacheWidth _ = 16384 -- a huge cache width!
seedIdentity _ = 1
identify _ UNil = Nil
identify i (UTip j) = Tip i j
View
@@ -16,27 +16,43 @@ module Data.Interned.Internal
, recover
) where
+import Data.Array
import Data.Hashable
import Data.HashMap.Strict (HashMap)
+import Data.Foldable
+import Data.Traversable
import qualified Data.HashMap.Strict as HashMap
import Control.Concurrent.MVar
import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)
import System.Mem.Weak
+-- tuning parameter
+defaultCacheWidth :: Int
+defaultCacheWidth = 1024
+
data CacheState t = CacheState
- {-# UNPACK #-} !Id
- !(HashMap (Description t) (Weak t))
+ { fresh :: {-# UNPACK #-} !Id
+ , content :: !(HashMap (Description t) (Weak t))
+ }
-newtype Cache t = Cache { getCache :: MVar (CacheState t) }
+newtype Cache t = Cache { getCache :: Array Int (MVar (CacheState t)) }
cacheSize :: Cache t -> IO Int
-cacheSize (Cache t) = do
- CacheState _ m <- readMVar t
- return (HashMap.size m)
+cacheSize (Cache t) = foldrM
+ (\a b -> do
+ v <- readMVar a
+ return $! HashMap.size (content v) + b
+ ) 0 t
mkCache :: Interned t => Cache t
-mkCache = result where
- result = Cache $ unsafePerformIO $ newMVar $ CacheState (seedIdentity result) HashMap.empty
+mkCache = result where
+ element = CacheState (seedIdentity result) HashMap.empty
+ w = cacheWidth result
+ result = Cache
+ $ unsafePerformIO
+ $ traverse newMVar
+ $ listArray (0,w - 1)
+ $ replicate w element
type Id = Int
@@ -50,6 +66,8 @@ class ( Eq (Description t)
identity :: t -> Id
seedIdentity :: p t -> Id
seedIdentity _ = 0
+ cacheWidth :: p t -> Int
+ cacheWidth _ = defaultCacheWidth
modifyAdvice :: IO t -> IO t
modifyAdvice = id
cache :: Cache t
@@ -58,26 +76,32 @@ class Interned t => Uninternable t where
unintern :: t -> Uninterned t
intern :: Interned t => Uninterned t -> t
-intern !bt = unsafeDupablePerformIO $ modifyAdvice $ modifyMVar (getCache cache) go
+intern !bt = unsafeDupablePerformIO $ modifyAdvice $ modifyMVar slot go
where
+ slot = getCache cache ! r
!dt = describe bt
+ !hdt = hash dt
+ !wid = cacheWidth dt
+ (q,r) = hdt `divMod` 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 i bt
+ k i m = do let t = identify (q * i + r) bt
wt <- t `seq` mkWeakPtr t $ Just remove
return (CacheState (i + 1) (HashMap.insert dt wt m), t)
- remove = modifyMVar_ (getCache cache) $
+ remove = modifyMVar_ slot $
\ (CacheState i m) -> return $ CacheState i (HashMap.delete dt m)
-- 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
+ CacheState _ m <- readMVar $ getCache cache ! (hash dt `mod` cacheWidth dt)
case HashMap.lookup dt m of
Nothing -> return Nothing
Just wt -> deRefWeak wt
+
View
@@ -25,7 +25,8 @@ library
bytestring >= 0.9.1 && < 0.10,
text >= 0.11.1.5 && < 0.12,
hashable >= 1.1.2 && < 1.2,
- unordered-containers >= 0.1.4 && < 0.2
+ unordered-containers >= 0.1.4 && < 0.2,
+ array >= 0.3.0.2 && < 0.4
exposed-modules:
Data.Interned

0 comments on commit 8b8dbd2

Please sign in to comment.