gameServer/Store.hs
author Wuzzy <Wuzzy2@mail.ru>
Wed, 21 Feb 2018 03:03:16 +0100
changeset 13044 1df5b407f368
parent 11046 47a8c19ecb60
permissions -rw-r--r--
Fix quit menu showing incorrect key when using non-default bindings
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
module Store(
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
    ElemIndex(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    22
    MStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    23
    IStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    24
    newStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
    addElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
    removeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
    readElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
    writeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
    modifyElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
    elemExists,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
    firstIndex,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
    indicesM,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
    withIStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
    withIStore2,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
    (!),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
    indices
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
    ) where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
import qualified Data.IntSet as IntSet
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    40
import qualified Data.Vector as V
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    41
import qualified Data.Vector.Mutable as MV
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
import Data.IORef
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    46
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    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
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    49
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, MV.IOVector e))
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    50
newtype IStore e = IStore (IntSet.IntSet, V.Vector e)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
firstIndex :: ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
firstIndex = ElemIndex 0
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
-- MStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
initialSize :: Int
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    58
initialSize = 16
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
growFunc :: Int -> Int
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
growFunc a = a * 3 `div` 2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
newStore :: IO (MStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
newStore = do
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    71
    newar <- MV.new initialSize
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    73
    return (MStore new)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    74
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    75
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    76
growStore :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    77
growStore (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    78
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    79
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    80
    let newSize = growFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    81
    newArr <- MV.grow arr (newSize - oldSize)
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    82
    writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [oldSize .. newSize-1], newArr)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    83
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    84
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    85
growIfNeeded :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    86
growIfNeeded m@(MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    87
    (_, freeElems, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    88
    when (IntSet.null freeElems) $ growStore m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    89
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    90
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    91
truncateIfNeeded :: MStore e -> IO ()
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    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
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    94
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    95
    let newSize = truncFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    96
    when (newSize < oldSize && (not $ IntSet.null busyElems) && IntSet.findMax busyElems < newSize) $ do
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   100
addElem :: MStore e -> e -> IO ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   101
addElem m@(MStore ref) element = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   102
    growIfNeeded m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   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
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   105
    MV.write arr n element
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   106
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   107
    return $ ElemIndex n
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   108
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   109
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   112
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   113
    MV.write arr n (error $ "Store: no element " ++ show n)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   116
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   117
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   118
readElem :: MStore e -> ElemIndex -> IO e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   119
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> MV.read arr n
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   120
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   121
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   122
writeElem :: MStore e -> ElemIndex -> e -> IO ()
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   123
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> MV.write arr n el
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   124
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   125
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   126
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   127
modifyElem (MStore ref) f (ElemIndex n) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   128
    (_, _, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   129
    MV.read arr n >>= MV.write arr n . f
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   130
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   131
elemExists :: MStore e -> ElemIndex -> IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   134
    return $ n `IntSet.notMember` free
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   135
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   136
indicesM :: MStore e -> IO [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   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
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   139
    return $ map ElemIndex $ IntSet.toList busy
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   140
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   141
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   142
-- A way to see MStore elements in pure code via IStore
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   143
m2i :: MStore e -> IO (IStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   144
m2i (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   145
    (a, _, c') <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   146
    c <- V.unsafeFreeze c'
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   147
    return $ IStore (a, c)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   148
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
   149
i2m :: MStore e -> IStore e -> IO ()
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   150
i2m (MStore ref) (IStore (_, arr)) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   151
    (b, e, _) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   152
    a <- V.unsafeThaw arr
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   153
    writeIORef ref (b, e, a)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   154
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   155
withIStore :: MStore e -> (IStore e -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   156
withIStore m f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   157
    i <- m2i m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   158
    let res = f i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   159
    res `seq` i2m m i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   160
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   161
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   162
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   163
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   164
withIStore2 m1 m2 f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   165
    i1 <- m2i m1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   166
    i2 <- m2i m2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   167
    let res = f i1 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   168
    res `seq` i2m m1 i1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   169
    i2m m2 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   170
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   171
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   172
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   173
-- IStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   174
(!) :: IStore e -> ElemIndex -> e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   175
(!) (IStore (_, arr)) (ElemIndex i) = (V.!) arr i
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   176
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   177
indices :: IStore e -> [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   178
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy