diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/apecs.cabal b/apecs.cabal --- a/apecs.cabal +++ b/apecs.cabal @@ -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 diff --git a/src/Apecs/Stores.hs b/src/Apecs/Stores.hs --- a/src/Apecs/Stores.hs +++ b/src/Apecs/Stores.hs @@ -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 ( 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. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)