diff --git a/apecs/CHANGELOG.md b/apecs/CHANGELOG.md index e4b7e5f..a0043bc 100644 --- a/apecs/CHANGELOG.md +++ b/apecs/CHANGELOG.md @@ -1,3 +1,29 @@ +## [0.10.0] +### Breaking Changes +- Dropped support for GHC <8.10.4 +- The lower bound for the `vector` library has been increased to `0.12.3.0`. + +### Changed +- Replaced the core `Map` store's `IntMap`-based backend with a sparse-set + implementation. This improves the performance of `set`, `get`, `exists`, and + `destroy` operations from O(log n) to O(1). +- The `Map` type is now an alias for `MapWith 16`. For component types with many + members, consider using `MapWith` to set a larger initial capacity and avoid + runtime allocations. +- Removed the `Cachable` instance for `Map`. The new sparse-set backend is as + fast as the previous `Cache (Map ...)` strategy, making the `Cache` wrapper + redundant for this store. +- The `Cachable` instance for `Map` is now considered obsolete. The new backend + is as fast as the previous `Cache (Map ...)` strategy. + +### Added +- Added `MapWith`, `UMapWith`, and `SMapWith` stores, which allow specifying an + initial capacity to pre-allocate memory. +- Added `UMap` for `Unbox`-able components and `SMap` for `Storable` components. + These stores offer the highest performance by reducing memory indirection and + improving data locality. + + ## [0.9.6] ### Changed - (#110) Relax upper bound on `mtl`: 2.3 -> 2.4 diff --git a/apecs/apecs.cabal b/apecs/apecs.cabal index ff5da72..3897712 100644 --- a/apecs/apecs.cabal +++ b/apecs/apecs.cabal @@ -39,14 +39,15 @@ library other-modules: Apecs.THTuples default-language: Haskell2010 build-depends: - array >=0.4 && <0.6 - , base >=4.9 && <5 - , containers >=0.5 && <0.8 - , exceptions >=0.10.0 && <0.11 - , mtl >=2.2 && <2.4 - , template-haskell >=2.12 && <3 - , unliftio-core >=0.2.0.1 && <0.3 - , vector >=0.11 && <0.14 + array >=0.4 && <0.6 + , base >=4.9 && <5 + , containers >=0.5 && <0.8 + , exceptions >=0.10.0 && <0.11 + , heph-sparse-set >=0.1 && <0.2 + , mtl >=2.2 && <2.4 + , template-haskell >=2.12 && <3 + , unliftio-core >=0.2.0.1 && <0.3 + , vector >=0.12.3.0 && <0.14 ghc-options: -Wall @@ -56,11 +57,11 @@ test-suite apecs-test hs-source-dirs: test build-depends: apecs - , base >=4.9 && <5 - , containers >=0.5 && <0.8 - , linear >=1.20 && <2 - , QuickCheck >=2.10 && <3 - , vector >=0.10 && <0.14 + , base >=4.9 && <5 + , containers >=0.5 && <0.8 + , linear >=1.20 && <2 + , QuickCheck >=2.10 && <3 + , vector >=0.12.3.0 && <0.14 default-language: Haskell2010 ghc-options: -Wall @@ -71,13 +72,13 @@ benchmark apecs-bench main-is: Main.hs build-depends: apecs - , base >=4.9 && <5 - , criterion >=1.3 && <2 - , linear >=1.20 && <2 + , base >=4.9 && <5 + , criterion >=1.3 && <2 + , linear >=1.20 && <2 + , vector >=0.12.3.0 && <0.14 default-language: Haskell2010 ghc-options: -Wall -O2 -optlo-O3 -threaded -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 -- -fllvm diff --git a/apecs/bench/Main.hs b/apecs/bench/Main.hs index 04d49a2..59a4f64 100644 --- a/apecs/bench/Main.hs +++ b/apecs/bench/Main.hs @@ -1,43 +1,149 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Main (main) where import Control.Monad import Criterion -import qualified Criterion.Main as C -import Criterion.Types +import qualified Criterion.Main as C +import Data.Typeable (Typeable, showsTypeRep, typeRep) +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import Foreign.Storable (Storable) import Linear import Apecs --- pos_vel -newtype ECSPos = ECSPos (V2 Float) deriving (Eq, Show) -instance Component ECSPos where type Storage ECSPos = Cache 10000 (Map ECSPos) +newtype ECSPos = ECSPos (V2 Float) deriving (Typeable, Eq, Show) +instance Component ECSPos where type Storage ECSPos = Map ECSPos -newtype ECSVel = ECSVel (V2 Float) deriving (Eq, Show) -instance Component ECSVel where type Storage ECSVel = Cache 1000 (Map ECSVel) +newtype ECSVel = ECSVel (V2 Float) deriving (Typeable, Eq, Show) +instance Component ECSVel where type Storage ECSVel = Map ECSVel makeWorld "PosVel" [''ECSPos, ''ECSVel] -posVelInit :: System PosVel () -posVelInit = do - replicateM_ 1000 $ newEntity (ECSPos 0, ECSVel 1) - replicateM_ 9000 $ newEntity (ECSPos 0) +deriving instance Typeable PosVel + +posVelInit :: Int -> System PosVel () +posVelInit n = do + replicateM_ n $ newEntity (ECSPos 0, ECSVel 1) + replicateM_ (9 * n) $ newEntity (ECSPos 0) posVelStep :: System PosVel () posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v) +newtype CachedECSPos = CachedECSPos (V2 Float) deriving (Typeable, Eq, Show) +instance Component CachedECSPos where type Storage CachedECSPos = Cache 10_000 (Map CachedECSPos) + +newtype CachedECSVel = CachedECSVel (V2 Float) deriving (Typeable, Eq, Show) +instance Component CachedECSVel where type Storage CachedECSVel = Cache 10_000 (Map CachedECSVel) + +makeWorld "CachedPosVel" [''CachedECSPos, ''CachedECSVel] + +deriving instance Typeable CachedPosVel + +cachedPosVelInit :: Int -> System CachedPosVel () +cachedPosVelInit n = do + replicateM_ n $ newEntity (CachedECSPos 0, CachedECSVel 1) + replicateM_ (9 * n) $ newEntity (CachedECSPos 0) + +cachedPosVelStep :: System CachedPosVel () +cachedPosVelStep = cmap $ \(CachedECSVel v, CachedECSPos p) -> CachedECSPos (p+v) + +newtype PreallocatedECSPos = PreallocatedECSPos (V2 Float) deriving (Typeable, Eq, Show) +instance Component PreallocatedECSPos where type Storage PreallocatedECSPos = MapWith 5_000 PreallocatedECSPos + +newtype PreallocatedECSVel = PreallocatedECSVel (V2 Float) deriving (Typeable, Eq, Show) +instance Component PreallocatedECSVel where type Storage PreallocatedECSVel = MapWith 5_000 PreallocatedECSVel + +makeWorld "PreallocatedPosVel" [''PreallocatedECSPos, ''PreallocatedECSVel] + +deriving instance Typeable PreallocatedPosVel + +preallocatedPosVelInit :: Int -> System PreallocatedPosVel () +preallocatedPosVelInit n = do + replicateM_ n $ newEntity (PreallocatedECSPos 0, PreallocatedECSVel 1) + replicateM_ (9 * n) $ newEntity (PreallocatedECSPos 0) + +preallocatedPosVelStep :: System PreallocatedPosVel () +preallocatedPosVelStep = cmap $ \(PreallocatedECSVel v, PreallocatedECSPos p) -> PreallocatedECSPos (p+v) + +newtype UECSPos = UECSPos (V2 Float) deriving (Typeable, Eq, Show) +instance Component UECSPos where type Storage UECSPos = UMap UECSPos + +newtype instance VU.MVector s UECSPos = MV_UECSPos (VU.MVector s (V2 Float)) +newtype instance VU.Vector UECSPos = V_UECSPos (VU.Vector (V2 Float)) +deriving instance VGM.MVector VU.MVector UECSPos +deriving instance VG.Vector VU.Vector UECSPos +instance VU.Unbox UECSPos + +newtype UECSVel = UECSVel (V2 Float) deriving (Typeable, Eq, Show) +instance Component UECSVel where type Storage UECSVel = UMap UECSVel + +newtype instance VU.MVector s UECSVel = MV_UECSVel (VU.MVector s (V2 Float)) +newtype instance VU.Vector UECSVel = V_UECSVel (VU.Vector (V2 Float)) +deriving instance VGM.MVector VU.MVector UECSVel +deriving instance VG.Vector VU.Vector UECSVel +instance VU.Unbox UECSVel + +makeWorld "UPosVel" [''UECSPos, ''UECSVel] + +deriving instance Typeable UPosVel + +uPosVelInit :: Int -> System UPosVel () +uPosVelInit n = do + replicateM_ n $ newEntity (UECSPos 0, UECSVel 1) + replicateM_ (9 * n) $ newEntity (UECSPos 0) + +uPosVelStep :: System UPosVel () +uPosVelStep = cmap $ \(UECSVel v, UECSPos p) -> UECSPos (p+v) + +newtype SECSPos = SECSPos (V2 Float) deriving (Typeable, Storable, Eq, Show) +instance Component SECSPos where type Storage SECSPos = SMap SECSPos + +newtype SECSVel = SECSVel (V2 Float) deriving (Typeable, Storable, Eq, Show) +instance Component SECSVel where type Storage SECSVel = SMap SECSVel + +makeWorld "SPosVel" [''SECSPos, ''SECSVel] + +deriving instance Typeable SPosVel + +sPosVelInit :: Int -> System SPosVel () +sPosVelInit n = do + replicateM_ n $ newEntity (SECSPos 0, SECSVel 1) + replicateM_ (9 * n) $ newEntity (SECSPos 0) + +sPosVelStep :: System SPosVel () +sPosVelStep = cmap $ \(SECSVel v, SECSPos p) -> SECSPos (p+v) + +benchWith :: forall w. (Typeable w) => IO w -> (Int -> System w ()) -> System w () -> Benchmark +benchWith initWorld initEntities stepEntities = + let gName = showsTypeRep (typeRep (Proxy :: Proxy w)) "" + n = 10_000 + in bgroup gName + [ bench "init world" $ whnfIO (initWorld >>= runSystem (pure ())) + , bench "init" $ whnfIO (initWorld >>= runSystem (initEntities n)) + , bench "step" $ whnfIO (initWorld >>= runSystem (initEntities n >> replicateM_ 1_000 stepEntities)) + ] + main :: IO () -main = C.defaultMainWith (C.defaultConfig {timeLimit = 10}) - [ bgroup "pos_vel" - [ bench "init" $ whnfIO (initPosVel >>= runSystem posVelInit) - , bench "step" $ whnfIO (initPosVel >>= runSystem (posVelInit >> posVelStep)) - ] +main = C.defaultMain + [ benchWith initPosVel posVelInit posVelStep + , benchWith initCachedPosVel cachedPosVelInit cachedPosVelStep + , benchWith initPreallocatedPosVel preallocatedPosVelInit preallocatedPosVelStep + , benchWith initUPosVel uPosVelInit uPosVelStep + , benchWith initSPosVel sPosVelInit sPosVelStep ] diff --git a/apecs/src/Apecs.hs b/apecs/src/Apecs.hs index e098629..e1fa364 100644 --- a/apecs/src/Apecs.hs +++ b/apecs/src/Apecs.hs @@ -8,7 +8,7 @@ module Apecs ( Get, Set, Destroy, Members, -- * Stores - Map, Unique, Global, Cache, + Map, MapWith, UMap, UMapWith, SMap, SMapWith, Unique, Global, Cache, explInit, -- * Systems @@ -30,7 +30,7 @@ module Apecs ( ) where import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask, asks, lift) +import Control.Monad.Reader (ask, asks, lift) import Data.Proxy import Apecs.Components @@ -81,3 +81,26 @@ import Apecs.Util -- get the best possible performance, always consider how maps and folds are -- executed under the hood, and how you can order your components to optimize -- that process. +-- +-- === Storage Strategies +-- +-- Apecs offers several storage options for components, allowing you to tune for +-- performance. +-- +-- * 'Map' (Default): The default store is now a high-performance sparse set +-- providing O(1) (amortized constant time) for nearly all operations. It is +-- suitable for the vast majority of component types. +-- +-- * 'UMap' and 'SMap': For performance-critical components, you can achieve +-- even greater speed by using these specialized stores. If your component can +-- be given an instance of 'Data.Vector.Unboxed.Unbox', use 'UMap'. If it has +-- a 'Foreign.Storable.Storable' instance, use 'SMap'. These stores lay out +-- data in contiguous memory blocks, which significantly improves cache +-- performance. +-- +-- * 'Cache': Previously, the `Cache` was the primary tool for achieving high +-- performance. With the new sparse-set backend for `Map`, `UMap`, and `SMap`, +-- the `Cache` is no longer necessary for these stores and is considered +-- obsolete for this purpose. It remains available for use with custom stores +-- that may have different performance characteristics. + diff --git a/apecs/src/Apecs/Stores.hs b/apecs/src/Apecs/Stores.hs index d9e0be8..b1231cc 100644 --- a/apecs/src/Apecs/Stores.hs +++ b/apecs/src/Apecs/Stores.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} module Apecs.Stores - ( Map, Cache, Unique, + ( Map, MapWith, UMap, UMapWith, SMapWith, SMap, Cache, Unique, Global, Cachable, ReadOnly, setReadOnly, destroyReadOnly @@ -21,29 +21,45 @@ module Apecs.Stores import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader -import Data.Bits (shiftL, (.&.)) -import qualified Data.IntMap.Strict as M +import Data.Bits (shiftL, (.&.)) import Data.IORef import Data.Proxy -import Data.Typeable (Typeable, typeRep) -import qualified Data.Vector.Mutable as VM -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as UM +import qualified Data.SparseSet.Mutable as SS +import qualified Data.SparseSet.Storable.Mutable as SSS +import qualified Data.SparseSet.Unboxed.Mutable as USS +import Data.Typeable (Typeable, typeRep) +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM +import Foreign (Storable) import GHC.TypeLits import Apecs.Core --- | A map based on 'Data.IntMap.Strict'. O(log(n)) for most operations. -newtype Map c = Map (IORef (M.IntMap c)) - -type instance Elem (Map c) = c -instance MonadIO m => ExplInit m (Map c) where - explInit = liftIO$ Map <$> newIORef mempty +-- | A map based on 'Data.SparseSet.Mutable' with a user-specified initial capacity. +-- +-- The type-level integer @n@ is an initial capacity hint. +newtype MapWith (n :: Nat) c = MapWith (SS.IOMutableSparseSet c) -instance (MonadIO m, Typeable c) => ExplGet m (Map c) where - explExists (Map ref) ety = liftIO$ M.member ety <$> readIORef ref - explGet (Map ref) ety = liftIO$ flip fmap (M.lookup ety <$> readIORef ref) $ \case - Just c -> c +-- | A map based on 'Data.SparseSet.Mutable'. O(1) for most operations. +-- +-- This is a type alias for @'MapWith' 16@. +-- +-- For component types that will have many instances, it is recommended to use 'MapWith' +-- to provide a larger initial capacity hint. +type Map c = MapWith 16 c + +type instance Elem (MapWith n c) = c +instance (MonadIO m, KnownNat n) => ExplInit m (MapWith n c) where + explInit = + let cap = fromIntegral $ natVal @n Proxy + in liftIO$ MapWith <$> SS.withCapacity cap (cap * 2) + +instance (MonadIO m, Typeable c) => ExplGet m (MapWith n c) where + explExists (MapWith ref) ety = liftIO$ SS.contains ref ety + explGet (MapWith ref) ety = liftIO$ SS.lookup ref ety >>= \case + Just c -> pure c notFound -> error $ unwords [ "Reading non-existent Map component" , show (typeRep notFound) @@ -53,19 +69,109 @@ instance (MonadIO m, Typeable c) => ExplGet m (Map c) where {-# INLINE explExists #-} {-# INLINE explGet #-} -instance MonadIO m => ExplSet m (Map c) where +instance MonadIO m => ExplSet m (MapWith n c) where + {-# INLINE explSet #-} + explSet (MapWith ref) ety x = liftIO$ + SS.insert ref ety x + +instance MonadIO m => ExplDestroy m (MapWith n c) where + {-# INLINE explDestroy #-} + explDestroy (MapWith ref) ety = liftIO$ + void $ SS.delete ref ety + +instance MonadIO m => ExplMembers m (MapWith n c) where + {-# INLINE explMembers #-} + explMembers (MapWith ref) = liftIO$ GV.convert <$> SS.members ref + +-- | An unboxed map with a user-specified initial capacity. +newtype UMapWith (n :: Nat) c = UMapWith (USS.IOMutableSparseSet c) + +-- | A map based on 'Data.SparseSet.Unboxed.Mutable' for unboxed components. O(1) for most operations. +-- Requires an `Unbox` instance for the component type. +-- +-- Offers higher performance than the standard `Map` by reducing memory indirection. +-- +-- This is a type alias for @'UMapWith' 16@. +type UMap c = UMapWith 16 c + +type instance Elem (UMapWith n c) = c +instance (MonadIO m, KnownNat n, U.Unbox c) => ExplInit m (UMapWith n c) where + explInit = + let cap = fromIntegral $ natVal @n Proxy + in liftIO$ UMapWith <$> USS.withCapacity cap (cap * 2) + +instance (MonadIO m, Typeable c, U.Unbox c) => ExplGet m (UMapWith n c) where + explExists (UMapWith ref) ety = liftIO$ USS.contains ref ety + explGet (UMapWith ref) ety = liftIO$ USS.lookup ref ety >>= \case + Just c -> pure c + notFound -> error $ unwords + [ "Reading non-existent UMap component" + , show (typeRep notFound) + , "for entity" + , show ety + ] + {-# INLINE explExists #-} + {-# INLINE explGet #-} + +instance (MonadIO m, U.Unbox c) => ExplSet m (UMapWith n c) where + {-# INLINE explSet #-} + explSet (UMapWith ref) ety x = liftIO$ + USS.insert ref ety x + +instance (MonadIO m, U.Unbox c) => ExplDestroy m (UMapWith n c) where + {-# INLINE explDestroy #-} + explDestroy (UMapWith ref) ety = liftIO$ + void $ USS.delete ref ety + +instance MonadIO m => ExplMembers m (UMapWith n c) where + {-# INLINE explMembers #-} + explMembers (UMapWith ref) = liftIO$ GV.convert <$> USS.members ref + +-- | A storable map with a user-specified initial capacity. +newtype SMapWith (n :: Nat) c = SMapWith (SSS.IOMutableSparseSet c) + +-- | A map based on 'Data.SparseSet.Storable.Mutable' for storable components. O(1) for most operations. +-- +-- Requires a `Storable` instance for the component type. +-- +-- Offers the highest performance by using a contiguous, packed memory layout. +-- +-- This is a type alias for @'SMapWith' 16@. +type SMap c = SMapWith 16 c + +type instance Elem (SMapWith n c) = c +instance (MonadIO m, KnownNat n, Storable c) => ExplInit m (SMapWith n c) where + explInit = + let cap = fromIntegral $ natVal @n Proxy + in liftIO$ SMapWith <$> SSS.withCapacity cap (cap * 2) + +instance (MonadIO m, Typeable c, Storable c) => ExplGet m (SMapWith n c) where + explExists (SMapWith ref) ety = liftIO$ SSS.contains ref ety + explGet (SMapWith ref) ety = liftIO$ SSS.lookup ref ety >>= \case + Just c -> pure c + notFound -> error $ unwords + [ "Reading non-existent SMap component" + , show (typeRep notFound) + , "for entity" + , show ety + ] + {-# INLINE explExists #-} + {-# INLINE explGet #-} + +instance (MonadIO m, Storable c) => ExplSet m (SMapWith n c) where {-# INLINE explSet #-} - explSet (Map ref) ety x = liftIO$ - modifyIORef' ref (M.insert ety x) + explSet (SMapWith ref) ety x = liftIO$ + SSS.insert ref ety x -instance MonadIO m => ExplDestroy m (Map c) where +instance (MonadIO m, Storable c) => ExplDestroy m (SMapWith n c) where {-# INLINE explDestroy #-} - explDestroy (Map ref) ety = liftIO$ - modifyIORef' ref (M.delete ety) + explDestroy (SMapWith ref) ety = liftIO$ + void $ SSS.delete ref ety -instance MonadIO m => ExplMembers m (Map c) where +instance MonadIO m => ExplMembers m (SMapWith n c) where {-# INLINE explMembers #-} - explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref + explMembers (SMapWith ref) = liftIO$ GV.convert <$> SSS.members ref + -- | A Unique contains zero or one component. -- Writing to it overwrites both the previous component and its owner. @@ -129,7 +235,11 @@ instance MonadIO m => ExplSet m (Global c) where -- | Class of stores that behave like a regular map, and can therefore safely be cached. -- This prevents stores like `Unique` and 'Global', which do /not/ behave like simple maps, from being cached. class Cachable s -instance Cachable (Map s) +-- | +-- __Note on Caching:__ This instance is provided for backward-compatibility, +-- but is considered obsolete. The `Cache` wrapper provides no significant +-- performance benefit for the sparse-set based `MapWith` store. +instance KnownNat n => Cachable (MapWith n s) instance (KnownNat n, Cachable s) => Cachable (Cache n s) -- | A cache around another store. diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs index 9608d94..1fb053b 100644 --- a/apecs/test/Main.hs +++ b/apecs/test/Main.hs @@ -2,8 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -17,7 +17,7 @@ import Control.Monad import qualified Data.Foldable as F import qualified Data.IntSet as S import Data.IORef -import Data.List ((\\), delete, nub, sort) +import Data.List (delete, nub, sort, (\\)) import qualified Data.Vector.Unboxed as U import Test.QuickCheck import Test.QuickCheck.Monadic @@ -181,7 +181,7 @@ prop_reactiveCounts writes deletes = assertSys initReactiveCountWld $ do -- Tests Pushdown newtype StackInt = StackInt Int deriving (Eq, Show, Arbitrary) -instance Component StackInt where type Storage StackInt = Pushdown Map StackInt +instance Component StackInt where type Storage StackInt = Pushdown (MapWith 16) StackInt makeWorld "StackWld" [''StackInt]