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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, NoImplicitPrelude, RecordWildCards #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Event.IntTable
(
IntTable
, new
, lookup
, insertWith
, reset
, delete
, updateWith
) where
import Data.Bits ((.&.), shiftL, shiftR)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (Maybe(..), isJust)
import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
import Foreign.Storable (peek, poke)
import GHC.Base (Monad(..), (=<<), ($), ($!), const, liftM, otherwise, when)
import GHC.Classes (Eq(..), Ord(..))
import GHC.Event.Arr (Arr)
import GHC.Num (Num(..))
import GHC.Prim (seq)
import GHC.Types (Bool(..), IO(..), Int(..))
import qualified GHC.Event.Arr as Arr
-- A very simple chained integer-keyed mutable hash table. We use
-- power-of-two sizing, grow at a load factor of 0.75, and never
-- shrink. The "hash function" is the identity function.
newtype IntTable a = IntTable (IORef (IT a))
data IT a = IT {
tabArr :: {-# UNPACK #-} !(Arr (Bucket a))
, tabSize :: {-# UNPACK #-} !(ForeignPtr Int)
}
data Bucket a = Empty
| Bucket {
bucketKey :: {-# UNPACK #-} !Int
, bucketValue :: a
, bucketNext :: Bucket a
}
lookup :: Int -> IntTable a -> IO (Maybe a)
lookup k (IntTable ref) = do
let go Bucket{..}
| bucketKey == k = Just bucketValue
| otherwise = go bucketNext
go _ = Nothing
it@IT{..} <- readIORef ref
bkt <- Arr.read tabArr (indexOf k it)
return $! go bkt
new :: Int -> IO (IntTable a)
new capacity = IntTable `liftM` (newIORef =<< new_ capacity)
new_ :: Int -> IO (IT a)
new_ capacity = do
arr <- Arr.new Empty capacity
size <- mallocForeignPtr
withForeignPtr size $ \ptr -> poke ptr 0
return IT { tabArr = arr
, tabSize = size
}
grow :: IT a -> IORef (IT a) -> Int -> IO ()
grow oldit ref size = do
newit <- new_ (Arr.size (tabArr oldit) `shiftL` 1)
let copySlot n !i
| n == size = return ()
| otherwise = do
let copyBucket !m Empty = copySlot m (i+1)
copyBucket m bkt@Bucket{..} = do
let idx = indexOf bucketKey newit
next <- Arr.read (tabArr newit) idx
Arr.write (tabArr newit) idx bkt { bucketNext = next }
copyBucket (m+1) bucketNext
copyBucket n =<< Arr.read (tabArr oldit) i
copySlot 0 0
withForeignPtr (tabSize newit) $ \ptr -> poke ptr size
writeIORef ref newit
-- | @insertWith f k v table@ inserts @k@ into @table@ with value @v@.
-- If @k@ already appears in @table@ with value @v0@, the value is updated
-- to @f v0 v@ and @Just v0@ is returned.
insertWith :: (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)
insertWith f k v inttable@(IntTable ref) = do
it@IT{..} <- readIORef ref
let idx = indexOf k it
go seen bkt@Bucket{..}
| bucketKey == k = do
let !v' = f v bucketValue
!next = seen <> bucketNext
Empty <> bs = bs
b@Bucket{..} <> bs = b { bucketNext = bucketNext <> bs }
Arr.write tabArr idx (Bucket k v' next)
return (Just bucketValue)
| otherwise = go bkt { bucketNext = seen } bucketNext
go seen _ = withForeignPtr tabSize $ \ptr -> do
size <- peek ptr
if size + 1 >= Arr.size tabArr - (Arr.size tabArr `shiftR` 2)
then grow it ref size >> insertWith f k v inttable
else do
v `seq` Arr.write tabArr idx (Bucket k v seen)
poke ptr (size + 1)
return Nothing
go Empty =<< Arr.read tabArr idx
{-# INLINABLE insertWith #-}
-- | Used to undo the effect of a prior insertWith.
reset :: Int -> Maybe a -> IntTable a -> IO ()
reset k (Just v) tbl = insertWith const k v tbl >> return ()
reset k Nothing tbl = delete k tbl >> return ()
indexOf :: Int -> IT a -> Int
indexOf k IT{..} = k .&. (Arr.size tabArr - 1)
-- | Remove the given key from the table and return its associated value.
delete :: Int -> IntTable a -> IO (Maybe a)
delete k t = updateWith (const Nothing) k t
updateWith :: (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a)
updateWith f k (IntTable ref) = do
it@IT{..} <- readIORef ref
let idx = indexOf k it
go bkt@Bucket{..}
| bucketKey == k = case f bucketValue of
Just val -> let !nb = bkt { bucketValue = val }
in (False, Just bucketValue, nb)
Nothing -> (True, Just bucketValue, bucketNext)
| otherwise = case go bucketNext of
(fbv, ov, nb) -> (fbv, ov, bkt { bucketNext = nb })
go e = (False, Nothing, e)
(del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx
when (isJust oldVal) $ do
Arr.write tabArr idx newBucket
when del $
withForeignPtr tabSize $ \ptr -> do
size <- peek ptr
poke ptr (size - 1)
return oldVal
|
