apecs 0.10.0 → 0.10.1

raw patch · 7 files changed

+169/−36 lines, 7 filesdep +deepseqdep +primitivedep +vector-th-unboxPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, primitive, vector-th-unbox

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• apecs.cabal +5/−1
• bench/Main.hs +79/−14
• src/Apecs.hs +3/−0
• src/Apecs/Stores.hs +3/−0
• src/Apecs/Stores/Internal.hs +37/−19
• test/Main.hs +38/−2

@@ -1,3 +1,7 @@+## [0.10.1]++- (#161) New Cache store variants. The old type is an alias for a cache parametrized by the old boxed vector. Faster Storable and Uboxed variants are available for the data that supports this.+ ## [0.10.0]  ### Changed

@@ -1,5 +1,5 @@ name:               apecs-version:            0.10.0+version:            0.10.1 homepage:           https://github.com/jonascarpay/apecs#readme license:            BSD3 license-file:       LICENSE@@ -52,6 +52,7 @@     , template-haskell  >=2.12   && <3     , foreign-store     >=0.2    && <0.3     , vector            >=0.11   && <0.14+    , primitive         >=0.1    && <0.10    ghc-options:      -Wall @@ -66,6 +67,7 @@     , linear      >=1.20 && <2     , QuickCheck  >=2.10 && <3     , vector+    , vector-th-unbox >= 0.2  && < 0.3    default-language: Haskell2010   ghc-options:      -Wall@@ -78,7 +80,9 @@       apecs     , base     , criterion  >=1.3  && <2+    , deepseq    >=1.4  && <2     , linear     >=1.20 && <2+    , vector-th-unbox >= 0.2  && < 0.3    default-language: Haskell2010   ghc-options:

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Strict #-}@@ -9,38 +10,102 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} +import Control.DeepSeq (NFData (..)) import Control.Monad import Criterion import qualified Criterion.Main as C import Criterion.Types+import Data.Vector.Unboxed.Deriving (derivingUnbox) import Linear  import Apecs+import Foreign (Storable) --- pos_vel-newtype ECSPos = ECSPos (V2 Float) deriving (Eq, Show)-instance Component ECSPos where type Storage ECSPos = Cache 10000 (Map ECSPos)+-- pos_vel, uncached+newtype Pos = Pos (V2 Float) deriving (Eq, Show)+instance Component Pos where type Storage Pos = Map Pos -newtype ECSVel = ECSVel (V2 Float) deriving (Eq, Show)-instance Component ECSVel where type Storage ECSVel = Cache 1000 (Map ECSVel)+newtype Vel = Vel (V2 Float) deriving (Eq, Show)+instance Component Vel where type Storage Vel = Map Vel -makeWorld "PosVel" [''ECSPos, ''ECSVel]+-- pos_vel, boxed cache+newtype BPos = BPos (V2 Float) deriving (Eq, Show)+instance Component BPos where type Storage BPos = Cache 10000 (Map BPos) -posVelInit :: System PosVel ()-posVelInit = do-  replicateM_ 1000 $ newEntity (ECSPos 0, ECSVel 1)-  replicateM_ 9000 $ newEntity (ECSPos 0)+newtype BVel = BVel (V2 Float) deriving (Eq, Show)+instance Component BVel where type Storage BVel = Cache 1000 (Map BVel) -posVelStep :: System PosVel ()-posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p + v)+-- pos_vel, storable cache+newtype SPos = SPos (V2 Float) deriving (Eq, Show, Storable)+instance Component SPos where type Storage SPos = SCache 10000 (Map SPos) +newtype SVel = SVel (V2 Float) deriving (Eq, Show, Storable)+instance Component SVel where type Storage SVel = SCache 1000 (Map SVel)++-- pos_vel, unboxed cache+newtype UPos = UPos (V2 Float) deriving (Eq, Show)+derivingUnbox "UPos" [t|UPos -> V2 Float|] [|\(UPos v) -> v|] [|UPos|]+instance Component UPos where type Storage UPos = UCache 10000 (Map UPos)++newtype UVel = UVel (V2 Float) deriving (Eq, Show)+derivingUnbox "UVel" [t|UVel -> V2 Float|] [|\(UVel v) -> v|] [|UVel|]+instance Component UVel where type Storage UVel = UCache 1000 (Map UVel)++makeWorld "PosVel" [''MPos, ''MVel, ''BPos, ''BVel, ''SPos, ''SVel, ''UPos, ''UVel]+instance NFData PosVel where rnf PosVel{} = ()++rawInit :: System PosVel ()+rawInit = do+  replicateM_ 1000 $ newEntity (Pos 0, Vel 1)+  replicateM_ 9000 $ newEntity (Pos 0)++rawStep :: System PosVel ()+rawStep = cmap $ \(Vel v, Pos p) -> Pos (p + v)++boxedInit :: System PosVel ()+boxedInit = do+  replicateM_ 1000 $ newEntity (BPos 0, BVel 1)+  replicateM_ 9000 $ newEntity (BPos 0)++boxedStep :: System PosVel ()+boxedStep = cmap $ \(BVel v, BPos p) -> BPos (p + v)++storableInit :: System PosVel ()+storableInit = do+  replicateM_ 1000 $ newEntity (SPos 0, SVel 1)+  replicateM_ 9000 $ newEntity (SPos 0)++storableStep :: System PosVel ()+storableStep = cmap $ \(SVel v, SPos p) -> SPos (p + v)++unboxedInit :: System PosVel ()+unboxedInit = do+  replicateM_ 1000 $ newEntity (UPos 0, UVel 1)+  replicateM_ 9000 $ newEntity (UPos 0)++unboxedStep :: System PosVel ()+unboxedStep = cmap $ \(UVel v, UPos p) -> UPos (p + v)++posVelGroup :: String -> System PosVel () -> System PosVel () -> Benchmark+posVelGroup name initSys stepSys =+  bgroup+    name+    [ bench "init" $ whnfIO (initPosVel >>= runSystem initSys)+    , bench "step" $+        perBatchEnv+          (\_ -> initPosVel >>= \w -> runSystem initSys w >> pure w)+          (runSystem stepSys)+    ]+ 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))+        [ posVelGroup "raw" rawInit rawStep+        , posVelGroup "boxed" boxedInit boxedStep+        , posVelGroup "storable" storableInit storableStep+        , posVelGroup "unboxed" unboxedInit unboxedStep         ]     ]

@@ -20,6 +20,9 @@   , Unique   , Global   , Cache+  , SCache+  , UCache+  , GCache   , explInit      -- * Systems

@@ -13,6 +13,9 @@ module Apecs.Stores   ( Map   , Cache+  , UCache+  , SCache+  , GCache   , Unique   , Global   , Cachable

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -9,10 +10,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}  module Apecs.Stores.Internal   ( Map (..)-  , Cache (..)+  , Cache+  , UCache+  , SCache+  , GCache (..)   , Unique (..)   , Global (..)   , Cachable@@ -23,14 +28,17 @@  import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Primitive (PrimState) import Control.Monad.Trans.Class (lift)-import Data.Bits (shiftL, (.&.))+import Data.Bits (countLeadingZeros, finiteBitSize, shiftL, (.&.)) import Data.IORef import qualified Data.IntMap.Strict as M import qualified Data.IntSet as IS import Data.Proxy import Data.Typeable (Typeable, typeRep)+import qualified Data.Vector.Generic.Mutable as GMV import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Storable.Mutable as SM import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as UM import GHC.TypeLits@@ -171,33 +179,43 @@   The actual cache is not necessarily the given argument, but the next biggest power of two.   This is allows most operations to be expressed as bit masks, for a large potential performance boost. -}-data Cache (n :: Nat) s-  = Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s+data GCache v (n :: Nat) s+  = Cache Int (UM.IOVector Int) (v (PrimState IO) (Elem s)) s -cacheMiss :: t-cacheMiss = error "Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"+-- | A cache for arbitrary types, using a boxed vector, adding an extra indirection for each component.+type Cache n s = GCache VM.MVector n s -type instance Elem (Cache n s) = Elem s+-- | A cache for unboxed types, using an unboxed vector, storing components directly in the cache.+type UCache n s = GCache UM.MVector n s -instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where+-- | A cache for storable types, using a storable vector, storing components directly in the cache.+type SCache n s = GCache SM.MVector n s++type instance Elem (GCache v n s) = Elem s++-- Hacker's Delight chapter 3+roundToPowerOfTwo :: Int -> Int+roundToPowerOfTwo n = 1 `shiftL` (finiteBitSize n - countLeadingZeros (n - 1))++instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s, GMV.MVector v (Elem s)) => ExplInit m (GCache v n s) where   {-# INLINE explInit #-}   explInit = do     let       n = fromIntegral $ natVal (Proxy @n) :: Int-      size = head . dropWhile (< n) $ iterate (`shiftL` 1) 1+      size = roundToPowerOfTwo n       mask = size - 1     tags <- liftIO $ UM.replicate size (-2)-    cache <- liftIO $ VM.replicate size cacheMiss+    cache <- liftIO $ GMV.unsafeNew size     child <- explInit     return (Cache mask tags cache child) -instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where+instance (MonadIO m, ExplGet m s, GMV.MVector v (Elem s), Elem s ~ Elem (GCache v n s)) => ExplGet m (GCache v n s) where   {-# INLINE explGet #-}   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+      liftIO $ GMV.unsafeRead cache index     else       explGet s ety @@ -206,28 +224,28 @@     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+instance (MonadIO m, ExplSet m s, GMV.MVector v (Elem s), Elem s ~ Elem (GCache v n s)) => ExplSet m (GCache v n s) where   {-# INLINE explSet #-}   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+      cached <- liftIO $ GMV.unsafeRead cache index       explSet s tag cached     liftIO $ UM.unsafeWrite tags index ety-    liftIO $ VM.unsafeWrite cache index x+    liftIO $ GMV.unsafeWrite cache index x -instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where+instance (MonadIO m, ExplDestroy m s, GMV.MVector v (Elem s), Elem s ~ Elem (GCache v n s)) => ExplDestroy m (GCache v n s) where   {-# INLINE explDestroy #-}-  explDestroy (Cache mask tags cache s) ety = do+  explDestroy (Cache mask tags _cache s) ety = do     let index = ety .&. mask     tag <- liftIO $ UM.unsafeRead tags (ety .&. mask)     when (tag == ety) $ liftIO $ do       UM.unsafeWrite tags index (-2)-      VM.unsafeWrite cache index cacheMiss+    -- GMV.unsafeWrite cache index cacheMiss     explDestroy s ety -instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where+instance (MonadIO m, ExplMembers m s) => ExplMembers m (GCache v n s) where   {-# INLINE explMembers #-}   explMembers (Cache mask tags _ s) = do     cached <- liftIO $ U.filter (/= (-2)) <$> U.freeze tags

@@ -20,6 +20,7 @@ import Data.List (delete, nub, sort, (\\)) import qualified Data.Map.Strict as M import qualified Data.Set as Set+import Data.Vector.Unboxed.Deriving (derivingUnbox) import Test.QuickCheck import Test.QuickCheck.Monadic import Text.Printf (printf)@@ -33,6 +34,7 @@ import Apecs.TH.Tags import Apecs.Tags import Apecs.Util+import Foreign (Storable)  -- Preamble instance Arbitrary Entity where@@ -135,6 +137,40 @@   es <- cfold (\a (_ :: CacheInt, Entity e) -> e : a) []   pure $ es == nub es +-- Tests whether this is also true for unboxed caches+newtype UCacheInt = UCacheInt Int deriving (Eq, Show, Arbitrary)+derivingUnbox "UCacheInt" [t|UCacheInt -> Int|] [|\(UCacheInt v) -> v|] [|UCacheInt|]+instance Component UCacheInt where type Storage UCacheInt = UCache 2 (Map UCacheInt)+makeWorld "UCached" [''UCacheInt]++prop_setGetUCache = genericSetGet initUCached (undefined :: UCacheInt)+prop_setSetUCache :: [(Entity, UCacheInt)] -> [Entity] -> Entity -> UCacheInt -> [(Entity, UCacheInt)] -> [Entity] -> UCacheInt -> [(Entity, UCacheInt)] -> [Entity] -> Property+prop_setSetUCache = genericSetSet initUCached (undefined :: UCacheInt)++prop_ucacheUnique :: [UCacheInt] -> [Entity] -> [(Entity, UCacheInt)] -> Property+prop_ucacheUnique eInit eDel eSet = assertSys initUCached $ do+  mapM_ newEntity eInit+  mapM_ (flip set (Not @UCacheInt)) eDel+  mapM_ (uncurry set) eSet+  es <- cfold (\a (_ :: UCacheInt, Entity e) -> e : a) []+  pure $ es == nub es++-- Tests whether this is also true for unboxed caches+newtype SCacheInt = SCacheInt Int deriving (Eq, Show, Arbitrary, Storable)+instance Component SCacheInt where type Storage SCacheInt = SCache 2 (Map SCacheInt)+makeWorld "SCached" [''SCacheInt]++prop_setGetSCache = genericSetGet initSCached (undefined :: SCacheInt)+prop_setSetSCache = genericSetSet initSCached (undefined :: SCacheInt)++prop_scacheUnique :: [SCacheInt] -> [Entity] -> [(Entity, SCacheInt)] -> Property+prop_scacheUnique eInit eDel eSet = assertSys initSCached $ do+  mapM_ newEntity eInit+  mapM_ (flip set (Not @SCacheInt)) eDel+  mapM_ (uncurry set) eSet+  es <- cfold (\a (_ :: SCacheInt, Entity e) -> e : a) []+  pure $ es == nub es+ -- Tests basic tuple functionality newtype T1 = T1 Int deriving (Eq, Show, Arbitrary) newtype T2 = T2 Int deriving (Eq, Show, Arbitrary)@@ -270,8 +306,8 @@     has_t12s = S.fromList (map (unEntity . fst) t12s)     has_t3s = S.fromList (map (unEntity . fst) t3s)     tags ety =-        (if ety `S.member` has_t12s then [TT1, TT2] else [])-          ++ (if ety `S.member` has_t3s then [TT3] else [])+      (if ety `S.member` has_t12s then [TT1, TT2] else [])+        ++ (if ety `S.member` has_t3s then [TT3] else [])   let expected =         M.fromListWith           (+)