author | unc0rr |
Wed, 22 Apr 2015 23:33:16 +0300 | |
branch | qmlfrontend |
changeset 10898 | f373838129c2 |
parent 10460 | 8dcea9087d75 |
child 11046 | 47a8c19ecb60 |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
2 |
* Hedgewars, a free turn based strategy game |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
3 |
* Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com> |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
5 |
* This program is free software; you can redistribute it and/or modify |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
6 |
* it under the terms of the GNU General Public License as published by |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
9 |
* This program is distributed in the hope that it will be useful, |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
10 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
14 |
* You should have received a copy of the GNU General Public License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
15 |
* along with this program; if not, write to the Free Software |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
16 |
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
7751
diff
changeset
|
18 |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
19 |
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} |
4905 | 20 |
module Store( |
21 |
ElemIndex(), |
|
22 |
MStore(), |
|
23 |
IStore(), |
|
24 |
newStore, |
|
25 |
addElem, |
|
26 |
removeElem, |
|
27 |
readElem, |
|
28 |
writeElem, |
|
29 |
modifyElem, |
|
30 |
elemExists, |
|
31 |
firstIndex, |
|
32 |
indicesM, |
|
33 |
withIStore, |
|
34 |
withIStore2, |
|
35 |
(!), |
|
36 |
indices |
|
37 |
) where |
|
38 |
||
39 |
import qualified Data.IntSet as IntSet |
|
7751 | 40 |
import qualified Data.Vector as V |
41 |
import qualified Data.Vector.Mutable as MV |
|
4905 | 42 |
import Data.IORef |
43 |
import Control.Monad |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
44 |
import Control.DeepSeq |
4905 | 45 |
|
46 |
||
47 |
newtype ElemIndex = ElemIndex Int |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
48 |
deriving (Eq, Show, Read, Ord, NFData) |
7751 | 49 |
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, MV.IOVector e)) |
50 |
newtype IStore e = IStore (IntSet.IntSet, V.Vector e) |
|
4905 | 51 |
|
52 |
||
53 |
firstIndex :: ElemIndex |
|
54 |
firstIndex = ElemIndex 0 |
|
55 |
||
56 |
-- MStore code |
|
57 |
initialSize :: Int |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
58 |
initialSize = 16 |
4905 | 59 |
|
60 |
||
61 |
growFunc :: Int -> Int |
|
62 |
growFunc a = a * 3 `div` 2 |
|
63 |
||
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
64 |
truncFunc :: Int -> Int |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
65 |
truncFunc a | a > growFunc initialSize = (a `div` 2) |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
66 |
| otherwise = a |
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
67 |
|
4905 | 68 |
|
69 |
newStore :: IO (MStore e) |
|
70 |
newStore = do |
|
7751 | 71 |
newar <- MV.new initialSize |
4905 | 72 |
new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar) |
73 |
return (MStore new) |
|
74 |
||
75 |
||
76 |
growStore :: MStore e -> IO () |
|
77 |
growStore (MStore ref) = do |
|
78 |
(busyElems, freeElems, arr) <- readIORef ref |
|
7751 | 79 |
let oldSize = MV.length arr |
80 |
let newSize = growFunc oldSize |
|
81 |
newArr <- MV.grow arr (newSize - oldSize) |
|
82 |
writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [oldSize .. newSize-1], newArr) |
|
4905 | 83 |
|
84 |
||
85 |
growIfNeeded :: MStore e -> IO () |
|
86 |
growIfNeeded m@(MStore ref) = do |
|
87 |
(_, freeElems, _) <- readIORef ref |
|
88 |
when (IntSet.null freeElems) $ growStore m |
|
89 |
||
90 |
||
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
91 |
truncateIfNeeded :: MStore e -> IO () |
5119 | 92 |
truncateIfNeeded (MStore ref) = do |
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
93 |
(busyElems, _, arr) <- readIORef ref |
7751 | 94 |
let oldSize = MV.length arr |
95 |
let newSize = truncFunc oldSize |
|
96 |
when (newSize < oldSize && (not $ IntSet.null busyElems) && IntSet.findMax busyElems < newSize) $ do |
|
97 |
writeIORef ref (busyElems, IntSet.fromAscList [0..newSize - 1] `IntSet.difference` busyElems, MV.take newSize arr) |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
98 |
|
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
99 |
|
4905 | 100 |
addElem :: MStore e -> e -> IO ElemIndex |
101 |
addElem m@(MStore ref) element = do |
|
102 |
growIfNeeded m |
|
103 |
(busyElems, freeElems, arr) <- readIORef ref |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
104 |
let (!n, freeElems') = IntSet.deleteFindMin freeElems |
7751 | 105 |
MV.write arr n element |
4905 | 106 |
writeIORef ref (IntSet.insert n busyElems, freeElems', arr) |
107 |
return $ ElemIndex n |
|
108 |
||
109 |
||
110 |
removeElem :: MStore e -> ElemIndex -> IO () |
|
5003
db4726bf9205
Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents:
4932
diff
changeset
|
111 |
removeElem m@(MStore ref) (ElemIndex n) = do |
4905 | 112 |
(busyElems, freeElems, arr) <- readIORef ref |
7751 | 113 |
MV.write arr n (error $ "Store: no element " ++ show n) |
4905 | 114 |
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
|
115 |
truncateIfNeeded m |
4905 | 116 |
|
117 |
||
118 |
readElem :: MStore e -> ElemIndex -> IO e |
|
7751 | 119 |
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> MV.read arr n |
4905 | 120 |
|
121 |
||
122 |
writeElem :: MStore e -> ElemIndex -> e -> IO () |
|
7751 | 123 |
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> MV.write arr n el |
4905 | 124 |
|
125 |
||
126 |
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO () |
|
127 |
modifyElem (MStore ref) f (ElemIndex n) = do |
|
128 |
(_, _, arr) <- readIORef ref |
|
7751 | 129 |
MV.read arr n >>= MV.write arr n . f |
4905 | 130 |
|
131 |
elemExists :: MStore e -> ElemIndex -> IO Bool |
|
132 |
elemExists (MStore ref) (ElemIndex n) = do |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
133 |
(_, !free, _) <- readIORef ref |
4905 | 134 |
return $ n `IntSet.notMember` free |
135 |
||
136 |
indicesM :: MStore e -> IO [ElemIndex] |
|
137 |
indicesM (MStore ref) = do |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
5119
diff
changeset
|
138 |
(!busy, _, _) <- readIORef ref |
4905 | 139 |
return $ map ElemIndex $ IntSet.toList busy |
140 |
||
141 |
||
142 |
-- A way to see MStore elements in pure code via IStore |
|
143 |
m2i :: MStore e -> IO (IStore e) |
|
144 |
m2i (MStore ref) = do |
|
145 |
(a, _, c') <- readIORef ref |
|
7751 | 146 |
c <- V.unsafeFreeze c' |
4905 | 147 |
return $ IStore (a, c) |
148 |
||
4932 | 149 |
i2m :: MStore e -> IStore e -> IO () |
4905 | 150 |
i2m (MStore ref) (IStore (_, arr)) = do |
151 |
(b, e, _) <- readIORef ref |
|
7751 | 152 |
a <- V.unsafeThaw arr |
4905 | 153 |
writeIORef ref (b, e, a) |
154 |
||
155 |
withIStore :: MStore e -> (IStore e -> a) -> IO a |
|
156 |
withIStore m f = do |
|
157 |
i <- m2i m |
|
158 |
let res = f i |
|
159 |
res `seq` i2m m i |
|
160 |
return res |
|
161 |
||
162 |
||
163 |
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a |
|
164 |
withIStore2 m1 m2 f = do |
|
165 |
i1 <- m2i m1 |
|
166 |
i2 <- m2i m2 |
|
167 |
let res = f i1 i2 |
|
168 |
res `seq` i2m m1 i1 |
|
169 |
i2m m2 i2 |
|
170 |
return res |
|
171 |
||
172 |
||
173 |
-- IStore code |
|
174 |
(!) :: IStore e -> ElemIndex -> e |
|
7751 | 175 |
(!) (IStore (_, arr)) (ElemIndex i) = (V.!) arr i |
4905 | 176 |
|
177 |
indices :: IStore e -> [ElemIndex] |
|
178 |
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy |