apecs 0.8.0 → 0.8.1
raw patch · 4 files changed
+51/−29 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- apecs.cabal +1/−1
- src/Apecs/Stores.hs +19/−15
- test/Main.hs +26/−13
CHANGELOG.md view
@@ -1,3 +1,8 @@+## [0.8.1]+### Changed+- Changed `Cache`s to use bitmasks instead of the remainder operation. This makes caches up to three times faster.+- Fixed bug in `Cache` where the same entity appeared in member list of both the cache and the underlying store+ ## [0.8.0] There are a number of unsolved problems in apecs' design space. Most notably, it needs a good way to do streaming and reactivity, or find a way to integrate with existing solutions.
apecs.cabal view
@@ -1,5 +1,5 @@ name: apecs-version: 0.8.0+version: 0.8.1 homepage: https://github.com/jonascarpay/apecs#readme license: BSD3 license-file: LICENSE
src/Apecs/Stores.hs view
@@ -21,6 +21,7 @@ import qualified Data.IntMap.Strict as M import Data.IORef import Data.Proxy+import Data.Bits (shiftL, (.&.)) import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as UM@@ -137,30 +138,32 @@ instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where {-# INLINE explInit #-} explInit = do- let n = fromIntegral$ natVal (Proxy @n)- tags <- liftIO$ UM.replicate n (-2)- cache <- liftIO$ VM.replicate n cacheMiss+ let n = fromIntegral$ natVal (Proxy @n) :: Int+ size = head . dropWhile (<n) $ iterate (`shiftL` 1) 1+ mask = size - 1+ tags <- liftIO$ UM.replicate size (-2)+ cache <- liftIO$ VM.replicate size cacheMiss child <- explInit- return (Cache n tags cache child)+ return (Cache mask tags cache child) instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where {-# INLINE explGet #-}- explGet (Cache n tags cache s) ety = do- let index = ety `rem` n+ explGet (Cache mask tags cache s) ety = do+ let index = ety .&. mask tag <- liftIO$ UM.unsafeRead tags index if tag == ety then liftIO$ VM.unsafeRead cache index else explGet s ety {-# INLINE explExists #-}- explExists (Cache n tags _ s) ety = do- tag <- liftIO$ UM.unsafeRead tags (ety `rem` n)+ explExists (Cache mask tags _ s) ety = do+ tag <- liftIO$ UM.unsafeRead tags (ety .&. mask) if tag == ety then return True else explExists s ety instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where {-# INLINE explSet #-}- explSet (Cache n tags cache s) ety x = do- let index = ety `rem` n+ explSet (Cache mask tags cache s) ety x = do+ let index = ety .&. mask tag <- liftIO$ UM.unsafeRead tags index when (tag /= (-2) && tag /= ety) $ do cached <- liftIO$ VM.unsafeRead cache index@@ -170,9 +173,9 @@ instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where {-# INLINE explDestroy #-}- explDestroy (Cache n tags cache s) ety = do- let index = ety `rem` n- tag <- liftIO$ UM.unsafeRead tags (ety `rem` n)+ explDestroy (Cache mask tags cache s) ety = do+ let index = ety .&. mask+ tag <- liftIO$ UM.unsafeRead tags (ety .&. mask) if tag == ety then do liftIO$ UM.unsafeWrite tags index (-2)@@ -181,9 +184,10 @@ instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where {-# INLINE explMembers #-}- explMembers (Cache _ tags _ s) = do+ explMembers (Cache mask tags _ s) = do cached <- liftIO$ U.filter (/= (-2)) <$> U.freeze tags- stored <- explMembers s+ let etyFilter ety = (/= ety) <$> UM.unsafeRead tags (ety .&. mask)+ stored <- explMembers s >>= liftIO . U.filterM etyFilter return $! cached U.++ stored -- | Wrapper that makes a store read-only by hiding its 'ExplSet' and 'ExplDestroy'. Use 'setReadOnly' and 'destroyReadOnly' to override.
test/Main.hs view
@@ -18,6 +18,7 @@ import qualified Data.Vector.Unboxed as U import Test.QuickCheck import Test.QuickCheck.Monadic+import Data.List (nub) import Apecs import Apecs.Core@@ -44,18 +45,18 @@ , Arbitrary c ) => IO w -> c- -> [(Entity, c)]- -> [Entity]- -> [(Entity, c)]+ -> [(Entity, c)] -> [Entity] -> Entity -> c+ -> [(Entity, c)] -> [Entity] -> Property-genericSetGet initSys _ sets1 dels sets2 ety c = do+genericSetGet initSys _ sets1 dels1 ety c sets2 dels2 = do assertSys initSys $ do -- insert and delete random data forM_ sets1 $ uncurry set- forM_ dels $ flip destroy (Proxy @c)- forM_ sets2 $ uncurry set+ forM_ dels1 $ flip destroy (Proxy @c) set ety c+ forM_ (filter ((/= ety) . fst) sets2) $ uncurry set+ forM_ (filter (/= ety) dels2) $ flip destroy (Proxy @c) c' <- get ety return (c == c') @@ -68,19 +69,23 @@ , Arbitrary c ) => IO w -> c- -> [(Entity, c)]- -> [Entity]- -> [(Entity, c)]- -> Entity -> c -> c+ -> [(Entity, c)] -> [Entity]+ -> Entity -> c+ -> [(Entity, c)] -> [Entity]+ -> c+ -> [(Entity, c)] -> [Entity] -> Property-genericSetSet initSys _ sets1 dels sets2 ety c1 c2 = do+genericSetSet initSys _ sets1 dels1 ety c1 sets2 dels2 c2 sets3 dels3 = do assertSys initSys $ do -- insert and delete random data forM_ sets1 $ uncurry set- forM_ dels $ flip destroy (Proxy @c)- forM_ sets2 $ uncurry set+ forM_ dels1 $ flip destroy (Proxy @c) set ety c1+ forM_ (filter ((/= ety) . fst) sets2) $ uncurry set+ forM_ (filter (/= ety) dels2) $ flip destroy (Proxy @c) set ety c2+ forM_ (filter ((/= ety) . fst) sets3) $ uncurry set+ forM_ (filter (/= ety) dels3) $ flip destroy (Proxy @c) c' <- get ety return (c2 == c') @@ -99,6 +104,14 @@ prop_setGetCache = genericSetGet initCached (undefined :: CacheInt) prop_setSetCache = genericSetSet initCached (undefined :: CacheInt)++prop_cacheUnique :: [CacheInt] -> [Entity] -> [(Entity, CacheInt)] -> Property+prop_cacheUnique eInit eDel eSet = assertSys initCached $ do+ mapM newEntity eInit+ mapM (flip set (Not @CacheInt)) eDel+ mapM (uncurry set) eSet+ es <- cfold (\a (_ :: CacheInt, Entity e) -> e : a) []+ pure $ es == nub es -- Tests basic tuple functionality newtype T1 = T1 Int deriving (Eq, Show, Arbitrary)