author | Henek |
Wed, 16 Mar 2011 22:45:42 +0100 | |
changeset 5014 | adc340265ccf |
parent 5003 | db4726bf9205 |
child 5119 | f475e10c4081 |
permissions | -rw-r--r-- |
4905 | 1 |
module Store( |
2 |
ElemIndex(), |
|
3 |
MStore(), |
|
4 |
IStore(), |
|
5 |
newStore, |
|
6 |
addElem, |
|
7 |
removeElem, |
|
8 |
readElem, |
|
9 |
writeElem, |
|
10 |
modifyElem, |
|
11 |
elemExists, |
|
12 |
firstIndex, |
|
13 |
indicesM, |
|
14 |
withIStore, |
|
15 |
withIStore2, |
|
16 |
(!), |
|
17 |
indices |
|
18 |
) where |
|
19 |
||
20 |
import qualified Data.Array.IArray as IA |
|
21 |
import qualified Data.Array.IO as IOA |
|
22 |
import qualified Data.IntSet as IntSet |
|
23 |
import Data.IORef |
|
24 |
import Control.Monad |
|
25 |
||
26 |
||
27 |
newtype ElemIndex = ElemIndex Int |
|
28 |
deriving (Eq, Show, Read, Ord) |
|
29 |
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e)) |
|
30 |
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e) |
|
31 |
||
32 |
||
33 |
firstIndex :: ElemIndex |
|
34 |
firstIndex = ElemIndex 0 |
|
35 |
||
36 |
-- MStore code |
|
37 |
initialSize :: Int |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
38 |
initialSize = 16 |
4905 | 39 |
|
40 |
||
41 |
growFunc :: Int -> Int |
|
42 |
growFunc a = a * 3 `div` 2 |
|
43 |
||
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
44 |
truncFunc :: Int -> Int |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
45 |
truncFunc a | a > growFunc initialSize = (a `div` 2) |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
46 |
| otherwise = a |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
47 |
|
4905 | 48 |
|
49 |
newStore :: IO (MStore e) |
|
50 |
newStore = do |
|
51 |
newar <- IOA.newArray_ (0, initialSize - 1) |
|
52 |
new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar) |
|
53 |
return (MStore new) |
|
54 |
||
55 |
||
56 |
growStore :: MStore e -> IO () |
|
57 |
growStore (MStore ref) = do |
|
58 |
(busyElems, freeElems, arr) <- readIORef ref |
|
59 |
(_, m') <- IOA.getBounds arr |
|
60 |
let newM' = growFunc (m' + 1) - 1 |
|
61 |
newArr <- IOA.newArray_ (0, newM') |
|
62 |
sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']] |
|
4932 | 63 |
writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [m'+1..newM'], newArr) |
4905 | 64 |
|
65 |
||
66 |
growIfNeeded :: MStore e -> IO () |
|
67 |
growIfNeeded m@(MStore ref) = do |
|
68 |
(_, freeElems, _) <- readIORef ref |
|
69 |
when (IntSet.null freeElems) $ growStore m |
|
70 |
||
71 |
||
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
72 |
truncateStore :: MStore e -> IO () |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
73 |
truncateStore (MStore ref) = do |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
74 |
(busyElems, freeElems, arr) <- readIORef ref |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
75 |
(_, m') <- IOA.getBounds arr |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
76 |
let newM' = truncFunc (m' + 1) - 1 |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
77 |
newArr <- IOA.newArray_ (0, newM') |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
78 |
sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- IntSet.toList busyElems] |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
79 |
writeIORef ref (busyElems, freeElems `IntSet.difference` IntSet.fromAscList [newM'..m'+1], newArr) |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
80 |
|
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
81 |
|
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
82 |
truncateIfNeeded :: MStore e -> IO () |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
83 |
truncateIfNeeded m@(MStore ref) = do |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
84 |
(busyElems, _, arr) <- readIORef ref |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
85 |
(_, m') <- IOA.getBounds arr |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
86 |
let newM' = truncFunc (m' + 1) - 1 |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
87 |
let allLessM = all (< newM') $ IntSet.elems busyElems |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
88 |
when (newM' < m' && allLessM) $ truncateStore m |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
89 |
|
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
90 |
|
4905 | 91 |
addElem :: MStore e -> e -> IO ElemIndex |
92 |
addElem m@(MStore ref) element = do |
|
93 |
growIfNeeded m |
|
94 |
(busyElems, freeElems, arr) <- readIORef ref |
|
95 |
let (n, freeElems') = IntSet.deleteFindMin freeElems |
|
96 |
IOA.writeArray arr n element |
|
97 |
writeIORef ref (IntSet.insert n busyElems, freeElems', arr) |
|
98 |
return $ ElemIndex n |
|
99 |
||
100 |
||
101 |
removeElem :: MStore e -> ElemIndex -> IO () |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
102 |
removeElem m@(MStore ref) (ElemIndex n) = do |
4905 | 103 |
(busyElems, freeElems, arr) <- readIORef ref |
104 |
IOA.writeArray arr n (error $ "Store: no element " ++ show n) |
|
105 |
writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr) |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
106 |
truncateIfNeeded m |
4905 | 107 |
|
108 |
||
109 |
readElem :: MStore e -> ElemIndex -> IO e |
|
110 |
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n |
|
111 |
||
112 |
||
113 |
writeElem :: MStore e -> ElemIndex -> e -> IO () |
|
114 |
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el |
|
115 |
||
116 |
||
117 |
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO () |
|
118 |
modifyElem (MStore ref) f (ElemIndex n) = do |
|
119 |
(_, _, arr) <- readIORef ref |
|
120 |
IOA.readArray arr n >>= IOA.writeArray arr n . f |
|
121 |
||
122 |
elemExists :: MStore e -> ElemIndex -> IO Bool |
|
123 |
elemExists (MStore ref) (ElemIndex n) = do |
|
124 |
(_, free, _) <- readIORef ref |
|
125 |
return $ n `IntSet.notMember` free |
|
126 |
||
127 |
indicesM :: MStore e -> IO [ElemIndex] |
|
128 |
indicesM (MStore ref) = do |
|
129 |
(busy, _, _) <- readIORef ref |
|
130 |
return $ map ElemIndex $ IntSet.toList busy |
|
131 |
||
132 |
||
133 |
-- A way to see MStore elements in pure code via IStore |
|
134 |
m2i :: MStore e -> IO (IStore e) |
|
135 |
m2i (MStore ref) = do |
|
136 |
(a, _, c') <- readIORef ref |
|
137 |
c <- IOA.unsafeFreeze c' |
|
138 |
return $ IStore (a, c) |
|
139 |
||
4932 | 140 |
i2m :: MStore e -> IStore e -> IO () |
4905 | 141 |
i2m (MStore ref) (IStore (_, arr)) = do |
142 |
(b, e, _) <- readIORef ref |
|
143 |
a <- IOA.unsafeThaw arr |
|
144 |
writeIORef ref (b, e, a) |
|
145 |
||
146 |
withIStore :: MStore e -> (IStore e -> a) -> IO a |
|
147 |
withIStore m f = do |
|
148 |
i <- m2i m |
|
149 |
let res = f i |
|
150 |
res `seq` i2m m i |
|
151 |
return res |
|
152 |
||
153 |
||
154 |
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a |
|
155 |
withIStore2 m1 m2 f = do |
|
156 |
i1 <- m2i m1 |
|
157 |
i2 <- m2i m2 |
|
158 |
let res = f i1 i2 |
|
159 |
res `seq` i2m m1 i1 |
|
160 |
i2m m2 i2 |
|
161 |
return res |
|
162 |
||
163 |
||
164 |
-- IStore code |
|
165 |
(!) :: IStore e -> ElemIndex -> e |
|
166 |
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i |
|
167 |
||
168 |
indices :: IStore e -> [ElemIndex] |
|
169 |
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy |