1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
{-# LANGUAGE TypeFamilies
, FlexibleInstances
, FlexibleContexts
, BangPatterns
, CPP
, GeneralizedNewtypeDeriving #-}
module Data.Interned.Internal
( Interned(..)
, Uninternable(..)
, mkCache
, Cache(..)
, CacheState(..)
, cacheSize
, Id
, intern
, recover
) where
import Data.Array
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Foldable
import Data.IORef
import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)
-- tuning parameter
defaultCacheWidth :: Int
defaultCacheWidth = 1024
data CacheState t = CacheState
{ fresh :: {-# UNPACK #-} !Id
, content :: !(HashMap (Description t) t)
}
newtype Cache t = Cache { getCache :: Array Int (IORef (CacheState t)) }
cacheSize :: Cache t -> IO Int
cacheSize (Cache t) = foldrM
(\a b -> do
v <- readIORef a
return $! HashMap.size (content v) + b
) 0 t
mkCache :: Interned t => Cache t
mkCache = result where
element = CacheState (seedIdentity result) HashMap.empty
w = cacheWidth result
result = Cache
$ unsafePerformIO
$ traverse newIORef
$ listArray (0,w - 1)
$ replicate w element
type Id = Int
class ( Eq (Description t)
, Hashable (Description t)
) => Interned t where
data Description t
type Uninterned t
describe :: Uninterned t -> Description t
identify :: Id -> Uninterned t -> 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
class Interned t => Uninternable t where
unintern :: t -> Uninterned t
intern :: Interned t => Uninterned t -> t
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 -> 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 <- readIORef $ getCache cache ! (hash dt `mod` cacheWidth dt)
return $ HashMap.lookup dt m
|
