gameServer/Store.hs
author koda
Tue, 18 Dec 2012 03:07:45 +0100
changeset 8310 a98c349bc06b
parent 7751 8c7f5c43ea5e
child 10460 8dcea9087d75
permissions -rw-r--r--
minor adjustments to libengine, moc is correctly created as definitions are set before calling it, params are better numbered and we don't subclass qthread but rather use moveToThread()
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
     1
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     2
module Store(
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     3
    ElemIndex(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     4
    MStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     5
    IStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     6
    newStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     7
    addElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     8
    removeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     9
    readElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    10
    writeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    11
    modifyElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    12
    elemExists,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    13
    firstIndex,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    14
    indicesM,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    15
    withIStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    16
    withIStore2,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    17
    (!),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    18
    indices
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    19
    ) where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
import qualified Data.IntSet as IntSet
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    22
import qualified Data.Vector as V
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    23
import qualified Data.Vector.Mutable as MV
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    24
import Data.IORef
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
import Control.Monad
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    26
import Control.DeepSeq
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
newtype ElemIndex = ElemIndex Int
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    30
    deriving (Eq, Show, Read, Ord, NFData)
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    31
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, MV.IOVector e))
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    32
newtype IStore e = IStore (IntSet.IntSet, V.Vector e)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
firstIndex :: ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
firstIndex = ElemIndex 0
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
-- MStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
initialSize :: Int
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    40
initialSize = 16
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    41
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    43
growFunc :: Int -> Int
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    44
growFunc a = a * 3 `div` 2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    46
truncFunc :: Int -> Int
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    47
truncFunc a | a > growFunc initialSize = (a `div` 2)
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    48
            | otherwise = a
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    49
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    50
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
newStore :: IO (MStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
newStore = do
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    53
    newar <- MV.new initialSize
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
    return (MStore new)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    58
growStore :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
growStore (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    61
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    62
    let newSize = growFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    63
    newArr <- MV.grow arr (newSize - oldSize)
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    64
    writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [oldSize .. newSize-1], newArr)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    65
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    66
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    67
growIfNeeded :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
growIfNeeded m@(MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
    (_, freeElems, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
    when (IntSet.null freeElems) $ growStore m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    71
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    73
truncateIfNeeded :: MStore e -> IO ()
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    74
truncateIfNeeded (MStore ref) = do
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    75
    (busyElems, _, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    76
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    77
    let newSize = truncFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    78
    when (newSize < oldSize && (not $ IntSet.null busyElems) && IntSet.findMax busyElems < newSize) $ do
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    79
        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
    80
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    81
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    82
addElem :: MStore e -> e -> IO ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    83
addElem m@(MStore ref) element = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    84
    growIfNeeded m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    85
    (busyElems, freeElems, arr) <- readIORef ref
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    86
    let (!n, freeElems') = IntSet.deleteFindMin freeElems
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    87
    MV.write arr n element
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    88
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    89
    return $ ElemIndex n
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    90
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    91
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    92
removeElem :: MStore e -> ElemIndex -> IO ()
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    93
removeElem m@(MStore ref) (ElemIndex n) = do
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    94
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    95
    MV.write arr n (error $ "Store: no element " ++ show n)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    96
    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
    97
    truncateIfNeeded m
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    98
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    99
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   100
readElem :: MStore e -> ElemIndex -> IO e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   101
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> MV.read arr n
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   102
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   103
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   104
writeElem :: MStore e -> ElemIndex -> e -> IO ()
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   105
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> MV.write arr n el
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   106
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   107
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   108
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   109
modifyElem (MStore ref) f (ElemIndex n) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   110
    (_, _, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   111
    MV.read arr n >>= MV.write arr n . f
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   112
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   113
elemExists :: MStore e -> ElemIndex -> IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   114
elemExists (MStore ref) (ElemIndex n) = do
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
   115
    (_, !free, _) <- readIORef ref
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   116
    return $ n `IntSet.notMember` free
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   117
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   118
indicesM :: MStore e -> IO [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   119
indicesM (MStore ref) = do
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
   120
    (!busy, _, _) <- readIORef ref
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   121
    return $ map ElemIndex $ IntSet.toList busy
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   122
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   123
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   124
-- A way to see MStore elements in pure code via IStore
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   125
m2i :: MStore e -> IO (IStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   126
m2i (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   127
    (a, _, c') <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   128
    c <- V.unsafeFreeze c'
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   129
    return $ IStore (a, c)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   130
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
   131
i2m :: MStore e -> IStore e -> IO ()
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   132
i2m (MStore ref) (IStore (_, arr)) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   133
    (b, e, _) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   134
    a <- V.unsafeThaw arr
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   135
    writeIORef ref (b, e, a)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   136
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   137
withIStore :: MStore e -> (IStore e -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   138
withIStore m f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   139
    i <- m2i m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   140
    let res = f i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   141
    res `seq` i2m m i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   142
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   143
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   144
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   145
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   146
withIStore2 m1 m2 f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   147
    i1 <- m2i m1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   148
    i2 <- m2i m2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   149
    let res = f i1 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   150
    res `seq` i2m m1 i1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   151
    i2m m2 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   152
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   153
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   154
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   155
-- IStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   156
(!) :: IStore e -> ElemIndex -> e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   157
(!) (IStore (_, arr)) (ElemIndex i) = (V.!) arr i
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   158
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   159
indices :: IStore e -> [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   160
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy