apecs-stm 0.2 → 0.3

raw patch · 8 files changed

+707/−209 lines, 8 filesdep +QuickCheckdep +apecs-stmdep +lineardep ~apecsdep ~basedep ~containerssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, apecs-stm, linear, tasty-bench, transformers

Dependency ranges changed: apecs, base, containers, stm-containers, template-haskell, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• Setup.hs +1/−0
• apecs-stm.cabal +39/−10
• bench/Main.hs +110/−0
• src/Apecs/STM.hs +0/−186
• src/Apecs/STM/Prelude.hs +0/−13
• src/Apecs/Stores/STM.hs +243/−0
• test/Main.hs +299/−0

@@ -1,3 +1,18 @@+## [0.3]++The package is now fully subordinate to vanilla apecs,+reusing its EntityCounter, makeWorld etc.++While it can still be used as "put everything into STM"+this is quite inefficient.++* Renamed Map, Global, Unique to TMap, TGlobal, TUnique.+  They now can be used alongside vanilla Map/Global/Unique+  and only where it matters.+* TMap.explMembers is not atomic under IO.+  Using stm-containers' listTNonAtomic escape hatch for+  single-threaded/non-atomic membership tests.+ ## [0.2] ### Removed - Removed custom `EntityCounter`, `newEntity`, and `makeWorld`.

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,5 +1,5 @@ name:               apecs-stm-version:            0.2+version:            0.3 homepage:           https://github.com/jonascarpay/apecs license:            BSD3 license-file:       LICENSE@@ -16,23 +16,52 @@  source-repository head   type:     git-  location: git://github.com/jonascarpay/apecs.git+  location: https://github.com/jonascarpay/apecs  library   hs-source-dirs:   src   exposed-modules:-    Apecs.STM-    Apecs.STM.Prelude+    Apecs.Stores.STM    default-language: Haskell2010   build-depends:-      apecs             >=0.9.3 && <0.10-    , base              >=4.9   && <5-    , containers        >=0.5   && <0.8+      apecs             >=0.9.3 && <0.11+    , base >=4.9 && <5+    , containers     , list-t            >=1     && <1.2     , stm               >=2.3   && <3-    , stm-containers    >=1.1   && <2-    , template-haskell  >=2.12  && <3-    , vector            >=0.10  && <0.14+    , stm-containers    >=1.2.1 && <2+    , template-haskell+    , transformers+    , vector    ghc-options:      -Wall++test-suite apecs-stm-test+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  hs-source-dirs:   test+  build-depends:+      apecs+    , apecs-stm+    , base+    , containers+    , QuickCheck  >=2.10 && <3+    , stm         >=2.3  && <3++  default-language: Haskell2010+  ghc-options:      -Wall -threaded -rtsopts "-with-rtsopts=-N"++benchmark apecs-stm-bench+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  hs-source-dirs:   bench+  build-depends:+      apecs+    , apecs-stm+    , base+    , linear       >=1.20 && <2+    , tasty-bench  >=0.3  && <0.5++  default-language: Haskell2010+  ghc-options:      -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N"

@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-}++{-| Benchmarks the same pos/vel init+step workload across three worlds:++  * @apecs-stm@: STM stores and the STM 'STM.newEntity' (run atomically).+  * vanilla @apecs@: 'Map' stores and the default 'newEntity'+    (backed by the non-atomic 'nextEntity').+  * vanilla @apecs@ using 'nextEntityIO': same as above, but allocating+    entities through the atomic 'nextEntityIO' counter path.+-}+module Main (main) where++import Control.Monad (replicateM_, void)+import Linear (V2)+import Test.Tasty.Bench++import Apecs+import qualified Apecs.Stores.STM as STM+import Apecs.Util (nextEntityIO)++-- Vanilla world -------------------------------------------------------------++newtype Pos = Pos (V2 Float) deriving (Eq, Show)+instance Component Pos where type Storage Pos = Map Pos++newtype Vel = Vel (V2 Float) deriving (Eq, Show)+instance Component Vel where type Storage Vel = Map Vel++makeWorld "Vanilla" [''Pos, ''Vel]++-- STM world -----------------------------------------------------------------++newtype SPos = SPos (V2 Float) deriving (Eq, Show)+instance Component SPos where type Storage SPos = STM.TMap SPos++newtype SVel = SVel (V2 Float) deriving (Eq, Show)+instance Component SVel where type Storage SVel = STM.TMap SVel++makeWorld "Stm" [''SPos, ''SVel]++-- Workloads -----------------------------------------------------------------++-- | Allocate an entity via the atomic IO counter, mirroring 'newEntity'.+newEntityIO :: (Set w IO c, Has w IO EntityCounter) => c -> SystemT w IO Entity+newEntityIO c = do+  ety <- nextEntityIO+  set ety c+  return ety++vanillaInit :: System Vanilla ()+vanillaInit = do+  replicateM_ 1000 $ void $ newEntity (Pos 0, Vel 1)+  replicateM_ 9000 $ void $ newEntity (Pos 0)++vanillaInitIO :: System Vanilla ()+vanillaInitIO = do+  replicateM_ 1000 $ void $ newEntityIO (Pos 0, Vel 1)+  replicateM_ 9000 $ void $ newEntityIO (Pos 0)++vanillaStep :: System Vanilla ()+vanillaStep = cmap $ \(Vel v, Pos p) -> Pos (p + v)++stmInit :: SystemT Stm STM.STM ()+stmInit = do+  replicateM_ 1000 $ void $ STM.newEntity (SPos 0, SVel 1)+  replicateM_ 9000 $ void $ STM.newEntity (SPos 0)++stmStep :: SystemT Stm STM.STM ()+stmStep = cmap $ \(SVel v, SPos p) -> SPos (p + v)++{- | Tasty pattern selecting the @vanilla@ benchmark within the given group,+used as the reference point for 'bcompare'.+-}+vsVanilla :: String -> String+vsVanilla grp = "$(NF-1) == \"" ++ grp ++ "\" && $NF == \"vanilla\""++main :: IO ()+main =+  defaultMain+    [ bgroup+        "init"+        [ bench "vanilla" $ whnfIO (initVanilla >>= runSystem vanillaInit)+        , bcompare (vsVanilla "init") $+            bench "vanilla-nextEntityIO" $+              whnfIO (initVanilla >>= runSystem vanillaInitIO)+        , bcompare (vsVanilla "init") $+            bench "apecs-stm" $+              whnfIO (initStm >>= runSystem (STM.atomically stmInit))+        ]+    , bgroup+        "step"+        [ bench "vanilla" $ whnfIO (initVanilla >>= runSystem (vanillaInit >> vanillaStep))+        , bcompare (vsVanilla "step") $+            bench "vanilla-nextEntityIO" $+              whnfIO (initVanilla >>= runSystem (vanillaInitIO >> vanillaStep))+        , bcompare (vsVanilla "step") $+            bench "apecs-stm" $+              whnfIO (initStm >>= runSystem (STM.atomically (stmInit >> stmStep)))+        ]+    ]

@@ -1,186 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}---- | This module contains STM-supporting versions of regular apecs stores, and some convenience functions.--- It is designed to be imported qualified, since it shadows both apecs and STM names.--- There is also an @Apecs.STM.Prelude@ module, which can be imported by itself.------ Note that if you want to be able to create entities in STM, you will also need to use a STM-supported @EntityCounter@, typically done through this module's @makeWorld@.--module Apecs.STM-  ( -- * Stores-    Map (..)-  , Unique (..)-  , Global (..)-    -- * STM conveniences-  , makeWorldAndComponents-  , atomically, retry, check, forkSys, threadDelay, STM-  ) where--import qualified Control.Concurrent          as S-import           Control.Concurrent.STM      (STM)-import qualified Control.Concurrent.STM      as S-import           Control.Concurrent.STM.TVar as S-import           Control.Monad-import           Data.Maybe-import           Data.Typeable (Typeable, typeRep)-import qualified Data.Vector.Unboxed         as U-import           Language.Haskell.TH-import qualified ListT                       as L-import qualified StmContainers.Map           as M--import           Apecs                       (ask, lift, liftIO, runSystem)-import           Apecs.Core-import           Apecs.TH                    (makeWorld, makeMapComponentsFor)--newtype Map c = Map (M.Map Int c)-type instance Elem (Map c) = c--instance ExplInit STM (Map c) where-  explInit = Map <$> M.new-instance Typeable c => ExplGet STM (Map c) where-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}-  explExists (Map m) ety = isJust   <$> M.lookup ety m-  explGet    (Map m) ety = flip fmap (M.lookup ety m) $ \case-    Just c -> c-    notFound -> error $ unwords-      [ "Reading non-existent STM Map component"-      , show (typeRep notFound)-      , "for entity"-      , show ety-      ]--instance ExplSet STM (Map c) where-  {-# INLINE explSet #-}-  explSet (Map m) ety x = M.insert x ety m-instance ExplDestroy STM (Map c) where-  {-# INLINE explDestroy #-}-  explDestroy (Map m) ety = M.delete ety m-instance ExplMembers STM (Map c) where-  {-# INLINE explMembers #-}-  explMembers (Map m) = U.unfoldrM L.uncons $ fst <$> M.listT m--instance ExplInit IO (Map c) where-  {-# INLINE explInit #-}-  explInit = S.atomically explInit-instance Typeable c => ExplGet IO (Map c) where-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}-  explExists m e = S.atomically $ explExists m e-  explGet m e = S.atomically $ explGet m e-instance ExplSet IO (Map c) where-  {-# INLINE explSet #-}-  explSet m e x = S.atomically $ explSet m e x-instance ExplDestroy IO (Map c) where-  {-# INLINE explDestroy #-}-  explDestroy m e = S.atomically $ explDestroy m e-instance ExplMembers IO (Map c) where-  {-# INLINE explMembers #-}-  explMembers m = S.atomically $ explMembers m--newtype Unique c = Unique (TVar (Maybe (Int, c)))-type instance Elem (Unique c) = c-instance ExplInit STM (Unique c) where-  explInit = Unique <$> newTVar Nothing--instance Typeable c => ExplGet STM (Unique c) where-  {-# INLINE explGet #-}-  explGet (Unique ref) _ = flip fmap (readTVar ref) $ \case-    Just (_, c)  -> c-    notFound -> error $ unwords-      [ "Reading non-existent STM Unique component"-      , show (typeRep notFound)-      ]-  {-# INLINE explExists #-}-  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVar ref--instance ExplSet STM (Unique c) where-  {-# INLINE explSet #-}-  explSet (Unique ref) ety c = writeTVar ref (Just (ety, c))--instance ExplDestroy STM (Unique c) where-  {-# INLINE explDestroy #-}-  explDestroy (Unique ref) ety = readTVar ref >>=-    mapM_ (flip when (writeTVar ref Nothing) . (==ety) . fst)--instance ExplMembers STM (Unique c) where-  {-# INLINE explMembers #-}-  explMembers (Unique ref) = flip fmap (readTVar ref) $ \case-    Nothing -> mempty-    Just (ety, _) -> U.singleton ety--instance ExplInit IO (Unique c) where-  {-# INLINE explInit #-}-  explInit = S.atomically explInit-instance Typeable c => ExplGet IO (Unique c) where-  {-# INLINE explExists #-}-  explExists m e = S.atomically $ explExists m e-  {-# INLINE explGet #-}-  explGet m e = S.atomically $ explGet m e-instance ExplSet IO (Unique c) where-  {-# INLINE explSet #-}-  explSet m e x = S.atomically $ explSet m e x-instance ExplDestroy IO (Unique c) where-  {-# INLINE explDestroy #-}-  explDestroy m e = S.atomically $ explDestroy m e-instance ExplMembers IO (Unique c) where-  {-# INLINE explMembers #-}-  explMembers m = S.atomically $ explMembers m--newtype Global c = Global (TVar c)-type instance Elem (Global c) = c-instance Monoid c => ExplInit STM (Global c) where-  {-# INLINE explInit #-}-  explInit = Global <$> newTVar mempty-instance ExplGet STM (Global c) where-  {-# INLINE explGet #-}-  explGet (Global ref) _ = readTVar ref-  {-# INLINE explExists #-}-  explExists _ _ = return True-instance ExplSet STM (Global c) where-  {-# INLINE explSet #-}-  explSet (Global ref) _ c = writeTVar ref c--instance Monoid c => ExplInit IO (Global c) where-  {-# INLINE explInit #-}-  explInit = S.atomically explInit-instance ExplGet IO (Global c) where-  {-# INLINE explExists #-}-  explExists m e = S.atomically $ explExists m e-  {-# INLINE explGet #-}-  explGet m e = S.atomically $ explGet m e-instance ExplSet IO (Global c) where-  {-# INLINE explSet #-}-  explSet m e x = S.atomically $ explSet m e x---- | Like @makeWorldAndComponents@ from @Apecs@, but uses the STM 'Map'-makeWorldAndComponents :: String -> [Name] -> Q [Dec]-makeWorldAndComponents worldName cTypes = do-  wdecls <- makeWorld worldName cTypes-  cdecls <- makeMapComponentsFor ''Map cTypes-  pure $ wdecls ++ cdecls---- | @atomically@ from STM, lifted to the System level.-atomically :: SystemT w STM a -> SystemT w IO a-atomically sys = ask >>= liftIO . S.atomically . runSystem sys---- | @retry@ from STM, lifted to the System level.-retry :: SystemT w STM a-retry = lift S.retry---- | @check@ from STM, lifted to the System level.-check :: Bool -> SystemT w STM ()-check = lift . S.check---- | Runs a system on a new thread.-forkSys :: SystemT w IO () -> SystemT w IO S.ThreadId-forkSys sys = ask >>= liftIO . S.forkIO . runSystem sys---- | Suspends the current thread for a number of microseconds.-threadDelay :: Int -> SystemT w IO ()-threadDelay = liftIO . S.threadDelay

@@ -1,13 +0,0 @@--- | This module re-exports the apecs prelude with STM versions.--module Apecs.STM.Prelude-  ( System-  , module Apecs.STM-  , module Apecs-  ) where--import           Apecs     hiding (Global, Map, System, Unique,-                            makeWorldAndComponents)-import           Apecs.STM--type System w a = SystemT w STM a

@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-| Stores and utilities that can partipicate in STM transactions.++Use sparingly!++Although this may be faster than always putting world under MVar,+grabbing too much entities and values in a single transaction would+incur quadratic costs.+-}+module Apecs.Stores.STM+  ( -- * Stores+    TMap (..)+  , TUnique (..)+  , TGlobal (..)++    -- * EntityCounter transactions+  , EntityCounter (..)+  , nextEntity+  , newEntity+  , newEntity_++    -- * STM conveniences+  , atomically+  , retry+  , check+  , forkSys+  , threadDelay+  , STM+  ) where++import qualified Control.Concurrent as S+import Control.Concurrent.STM (STM)+import qualified Control.Concurrent.STM as S+import Control.Concurrent.STM.TVar as S+import Control.Monad+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (lift)+import qualified Data.IntSet as IS+import Data.Maybe+import Data.Typeable (Typeable, typeRep)+import qualified Data.Vector.Unboxed as U+import GHC.Conc (unsafeIOToSTM)+import qualified ListT as L+import qualified StmContainers.Map as M++import Apecs (ask, runSystem, set)+import Apecs.Core+import Apecs.Util (EntityCounter (..), nextEntityIO)++newtype TMap c = TMap (M.Map Int c)+type instance Elem (TMap c) = c++instance ExplInit STM (TMap c) where+  explInit = TMap <$> M.new+instance (Typeable c) => ExplGet STM (TMap c) where+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}+  explExists (TMap m) ety = isJust <$> M.lookup ety m+  explGet (TMap m) ety = flip fmap (M.lookup ety m) $ \case+    Just c -> c+    notFound ->+      error $+        unwords+          [ "Reading non-existent STM Map component"+          , show (typeRep notFound)+          , "for entity"+          , show ety+          ]++instance ExplSet STM (TMap c) where+  {-# INLINE explSet #-}+  explSet (TMap m) ety x = M.insert x ety m+instance ExplDestroy STM (TMap c) where+  {-# INLINE explDestroy #-}+  explDestroy (TMap m) ety = M.delete ety m+instance ExplMembers STM (TMap c) where+  {-# INLINE explMembers #-}+  explMembers (TMap m) = U.unfoldrM L.uncons $ fst <$> M.listT m+  {-# INLINE explMemberSet #-}+  explMemberSet (TMap m) = IS.fromList <$> L.toList (fst <$> M.listT m)++instance ExplInit IO (TMap c) where+  {-# INLINE explInit #-}+  explInit = S.atomically explInit+instance (Typeable c) => ExplGet IO (TMap c) where+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}+  explExists m e = S.atomically $ explExists m e+  explGet m e = S.atomically $ explGet m e+instance ExplSet IO (TMap c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x+instance ExplDestroy IO (TMap c) where+  {-# INLINE explDestroy #-}+  explDestroy m e = S.atomically $ explDestroy m e+instance ExplMembers IO (TMap c) where+  {-# INLINE explMembers #-}+  explMembers (TMap m) = U.unfoldrM L.uncons $ fst <$> M.listTNonAtomic m+  {-# INLINE explMemberSet #-}+  explMemberSet (TMap m) =+    L.fold (\a b -> pure $! IS.insert b a) IS.empty $ fst <$> M.listTNonAtomic m++newtype TUnique c = TUnique (TVar (Maybe (Int, c)))+type instance Elem (TUnique c) = c+instance ExplInit STM (TUnique c) where+  explInit = TUnique <$> newTVar Nothing++instance (Typeable c) => ExplGet STM (TUnique c) where+  {-# INLINE explGet #-}+  explGet (TUnique ref) _ = flip fmap (readTVar ref) $ \case+    Just (_, c) -> c+    notFound ->+      error $+        unwords+          [ "Reading non-existent STM TUnique component"+          , show (typeRep notFound)+          ]+  {-# INLINE explExists #-}+  explExists (TUnique ref) ety = maybe False ((== ety) . fst) <$> readTVar ref++instance ExplSet STM (TUnique c) where+  {-# INLINE explSet #-}+  explSet (TUnique ref) ety c = writeTVar ref (Just (ety, c))++instance ExplDestroy STM (TUnique c) where+  {-# INLINE explDestroy #-}+  explDestroy (TUnique ref) ety =+    readTVar ref+      >>= mapM_ (flip when (writeTVar ref Nothing) . (== ety) . fst)++instance ExplMembers STM (TUnique c) where+  {-# INLINE explMembers #-}+  explMembers (TUnique ref) = flip fmap (readTVar ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> U.singleton ety+  {-# INLINE explMemberSet #-}+  explMemberSet (TUnique ref) = flip fmap (readTVar ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> IS.singleton ety++instance ExplInit IO (TUnique c) where+  {-# INLINE explInit #-}+  explInit = S.atomically explInit+instance (Typeable c) => ExplGet IO (TUnique c) where+  {-# INLINE explExists #-}+  explExists (TUnique ref) ety = maybe False ((== ety) . fst) <$> readTVarIO ref+  {-# INLINE explGet #-}+  explGet m e = S.atomically $ explGet m e+instance ExplSet IO (TUnique c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x+instance ExplDestroy IO (TUnique c) where+  {-# INLINE explDestroy #-}+  explDestroy m e = S.atomically $ explDestroy m e+instance ExplMembers IO (TUnique c) where+  {-# INLINE explMembers #-}+  explMembers (TUnique ref) = flip fmap (readTVarIO ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> U.singleton ety+  {-# INLINE explMemberSet #-}+  explMemberSet (TUnique ref) = flip fmap (readTVarIO ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> IS.singleton ety++newtype TGlobal c = TGlobal (TVar c)+type instance Elem (TGlobal c) = c+instance (Monoid c) => ExplInit STM (TGlobal c) where+  {-# INLINE explInit #-}+  explInit = TGlobal <$> newTVar mempty+instance ExplGet STM (TGlobal c) where+  {-# INLINE explGet #-}+  explGet (TGlobal ref) _ = readTVar ref+  {-# INLINE explExists #-}+  explExists _ _ = return True+instance ExplSet STM (TGlobal c) where+  {-# INLINE explSet #-}+  explSet (TGlobal ref) _ c = writeTVar ref c++instance (Monoid c) => ExplInit IO (TGlobal c) where+  {-# INLINE explInit #-}+  explInit = TGlobal <$> newTVarIO mempty+instance ExplGet IO (TGlobal c) where+  {-# INLINE explExists #-}+  explExists _ _ = return True+  {-# INLINE explGet #-}+  explGet (TGlobal ref) _ = readTVarIO ref+instance ExplSet IO (TGlobal c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x++{-# INLINE nextEntity #-}+nextEntity :: (Has w IO EntityCounter) => SystemT w STM Entity+nextEntity = ask >>= lift . unsafeIOToSTM . runSystem nextEntityIO++{-# INLINE newEntity #-}+newEntity :: (Set w STM c, Has w IO EntityCounter) => c -> SystemT w STM Entity+newEntity c = do+  ety <- nextEntity+  set ety c+  return ety++{-# INLINE newEntity_ #-}+newEntity_ :: (Set w STM c, Has w IO EntityCounter) => c -> SystemT w STM ()+newEntity_ c = do+  ety <- nextEntity+  set ety c++-- -- | Like @makeWorld@ from @Apecs@, but uses the STM @EntityCounter@+-- makeWorld :: String -> [Name] -> Q [Dec]+-- makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])++-- -- | Like @makeWorldAndComponents@ from @Apecs@, but uses the STM @EntityCounter@ and the STM @Map@+-- makeWorldAndComponents :: String -> [Name] -> Q [Dec]+-- makeWorldAndComponents worldName cTypes = do+--   wdecls <- makeWorld worldName cTypes+--   cdecls <- makeMapComponentsFor ''Map cTypes+--   pure $ wdecls ++ cdecls++-- | @atomically@ from STM, lifted to the System level.+atomically :: SystemT w STM a -> SystemT w IO a+atomically sys = ask >>= liftIO . S.atomically . runSystem sys++-- | @retry@ from STM, lifted to the System level.+retry :: SystemT w STM a+retry = lift S.retry++-- | @check@ from STM, lifted to the System level.+check :: Bool -> SystemT w STM ()+check = lift . S.check++-- | Runs a system on a new thread.+forkSys :: SystemT w IO () -> SystemT w IO S.ThreadId+forkSys sys = ask >>= liftIO . S.forkIO . runSystem sys++-- | Suspends the current thread for a number of microseconds.+threadDelay :: Int -> SystemT w IO ()+threadDelay = liftIO . S.threadDelay

@@ -0,0 +1,299 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-}++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import qualified Control.Concurrent.STM as C+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Data.List (nub, sort)+import Data.Monoid (Sum (..))+import Data.Proxy (Proxy (..))+import System.Timeout (timeout)+import Test.QuickCheck+import Test.QuickCheck.Monadic++import Apecs (Cache, Map, cfold, destroy, exists, get, global, modify, runSystem, set)+import Apecs.Core+import Apecs.Stores.STM (STM)+import qualified Apecs.Stores.STM as STM+import Apecs.TH (makeWorld)++-- Preamble ------------------------------------------------------------------++instance Arbitrary Entity where+  arbitrary = Entity . getNonNegative <$> arbitrary++-- | Run a @SystemT w IO Bool@ as a QuickCheck property (IO instances).+assertSys :: IO w -> SystemT w IO Bool -> Property+assertSys initW sys = monadicIO $ run (initW >>= runSystem sys) >>= assert++{- | Run a @SystemT w STM Bool@ as a QuickCheck property, driving the STM+instances directly through @atomically@.+-}+assertSTM :: IO w -> SystemT w STM Bool -> Property+assertSTM initW sys = monadicIO $ run (initW >>= runSystem (STM.atomically sys)) >>= assert++-- Components & world --------------------------------------------------------++newtype MapInt = MapInt Int deriving (Eq, Show, Arbitrary)+newtype UniqueInt = UniqueInt Int deriving (Eq, Show, Arbitrary)+newtype GlobalSum = GlobalSum (Sum Int) deriving (Eq, Show, Semigroup, Monoid, Arbitrary)++instance Component MapInt where type Storage MapInt = STM.TMap MapInt+instance Component UniqueInt where type Storage UniqueInt = STM.TUnique UniqueInt+instance Component GlobalSum where type Storage GlobalSum = STM.TGlobal GlobalSum++-- Generates @World@, @initWorld :: IO World@, and @EntityCounter@.+makeWorld "World" [''MapInt, ''UniqueInt, ''GlobalSum]++{- | An IO-only store: a cached 'Map'. It has no STM instances, so it can only+be touched from IO systems, never from inside an STM transaction.+-}+newtype CachedInt = CachedInt Int deriving (Eq, Show, Arbitrary)++instance Component CachedInt where type Storage CachedInt = Cache 64 (Map CachedInt)++{- | A single world that mixes an IO-only cached 'Map' (@CachedInt@) with an+STM 'STM.TMap' (@MapInt@). The IO-backed 'STM.EntityCounter' added by+@makeWorld@ ties the two together: entities are allocated in IO but can be+populated either in IO (the cache) or inside a transaction (the TMap).++Generates @MixedWorld@ and @initMixedWorld :: IO MixedWorld@.+-}+makeWorld "MixedWorld" [''CachedInt, ''MapInt]++-- Map: set/get roundtrips ---------------------------------------------------++{- | Monad-polymorphic set/get body so the same logic runs over both the IO+and STM instance sets of the store.+-}+setGetBody+  :: forall w m c+   . (Get w m c, Set w m c, Destroy w m c, Eq c)+  => Proxy c+  -> [(Entity, c)]+  -> [Entity]+  -> Entity+  -> c+  -> [(Entity, c)]+  -> [Entity]+  -> SystemT w m Bool+setGetBody _ sets1 dels1 ety c sets2 dels2 = do+  forM_ sets1 $ 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')++prop_setGetMapIO+  :: [(Entity, MapInt)] -> [Entity] -> Entity -> MapInt -> [(Entity, MapInt)] -> [Entity] -> Property+prop_setGetMapIO s1 d1 e c s2 d2 =+  assertSys initWorld (setGetBody (Proxy @MapInt) s1 d1 e c s2 d2)++prop_setGetMapSTM+  :: [(Entity, MapInt)] -> [Entity] -> Entity -> MapInt -> [(Entity, MapInt)] -> [Entity] -> Property+prop_setGetMapSTM s1 d1 e c s2 d2 =+  assertSTM initWorld (setGetBody (Proxy @MapInt) s1 d1 e c s2 d2)++-- Map: members and destroy --------------------------------------------------++prop_mapMembers :: [(Entity, MapInt)] -> [Entity] -> Property+prop_mapMembers sets dels = assertSys initWorld $ do+  forM_ sets $ uncurry set+  forM_ dels $ flip destroy (Proxy @MapInt)+  present <- cfold (\acc (_ :: MapInt, e :: Entity) -> e : acc) []+  -- The live set is everything we set, minus everything we deleted.+  let expected = nub [e | (e, _) <- sets, e `notElem` dels]+  pure $ sort present == sort expected++-- Unique: at most one live entity ------------------------------------------++prop_uniqueSingle :: NonEmptyList (Entity, UniqueInt) -> Property+prop_uniqueSingle (NonEmpty kvs) = assertSys initWorld $ do+  forM_ kvs $ uncurry set+  let (lastE, lastV) = last kvs+  ex <- exists lastE (Proxy @UniqueInt)+  v <- get lastE+  ms <- cfold (\acc (_ :: UniqueInt, e :: Entity) -> e : acc) []+  pure $ ex && v == lastV && length ms <= 1++prop_uniqueDestroy :: Entity -> UniqueInt -> Property+prop_uniqueDestroy e v = assertSys initWorld $ do+  set e v+  destroy e (Proxy @UniqueInt)+  not <$> exists e (Proxy @UniqueInt)++-- Global --------------------------------------------------------------------++prop_globalSetGet :: Entity -> GlobalSum -> Property+prop_globalSetGet e v = assertSys initWorld $ do+  set e v+  v' <- get e+  ex <- exists e (Proxy @GlobalSum)+  pure $ v == v' && ex++prop_globalDefault :: Property+prop_globalDefault = once $ assertSys initWorld $ do+  v <- get global+  pure $ v == (mempty :: GlobalSum)++-- Entity creation in STM ----------------------------------------------------++prop_newEntityFresh :: Property+prop_newEntityFresh = once $ assertSys initWorld $ do+  let n = 100+  es <- STM.atomically $ replicateM n (STM.newEntity (MapInt 0))+  let ids = [e | Entity e <- es]+  STM.EntityCounter (Sum c) <- get global+  pure $ length (nub ids) == n && c == n++-- check / retry -------------------------------------------------------------++prop_checkProceeds :: Entity -> MapInt -> Property+prop_checkProceeds e v = once $ assertSys initWorld $ do+  set e v+  r <- STM.atomically $ do+    ex <- exists e (Proxy @MapInt)+    STM.check ex+    get e+  pure $ r == v++{- | A consumer transaction blocks on @check@ (i.e. STM @retry@) until a+producer writes the component, then observes the written value.+-}+prop_retryProducerConsumer :: Property+prop_retryProducerConsumer = once $ monadicIO $ do+  res <- run $ do+    w <- initWorld+    let+      e = Entity 5+      target = MapInt 42+    result <- newEmptyMVar+    _ <- forkIO $ flip runSystem w $ do+      v <- STM.atomically $ do+        ex <- exists e (Proxy @MapInt)+        STM.check ex+        get e+      liftIO $ putMVar result v+    -- Let the consumer reach its retry, then produce.+    threadDelay 50000+    runSystem (STM.atomically (set e target)) w+    timeout 2000000 (takeMVar result)+  assert (res == Just (MapInt 42))++-- Concurrency ---------------------------------------------------------------++{- | Many threads concurrently allocate entities; the IO-backed EntityCounter+must hand out unique ids and the STM Map must hold them all.+-}+prop_concurrentNewEntity :: Property+prop_concurrentNewEntity = once $ monadicIO $ do+  let+    nThreads = 8+    perThread = 200+  (totalIds, uniqueIds, memberCount) <- run $ do+    w <- initWorld+    collected <- C.newTVarIO ([] :: [Int])+    dones <- replicateM nThreads newEmptyMVar+    flip runSystem w $ do+      forM_ dones $ \done -> STM.forkSys $ do+        forM_ [1 .. perThread] $ \_ -> do+          Entity e <- STM.atomically (STM.newEntity (MapInt 0))+          liftIO $ C.atomically $ C.modifyTVar' collected (e :)+        liftIO $ putMVar done ()+      liftIO $ mapM_ takeMVar dones+    ids <- C.atomically (C.readTVar collected)+    mc <- runSystem (cfold (\acc (_ :: MapInt, _ :: Entity) -> acc + 1) (0 :: Int)) w+    pure (length ids, length (nub ids), mc)+  assert $ totalIds == nThreads * perThread && uniqueIds == totalIds && memberCount == totalIds++-- | Concurrent atomic increments of a Global must not lose updates.+prop_concurrentGlobal :: Property+prop_concurrentGlobal = once $ monadicIO $ do+  let+    nThreads = 8+    perThread = 500+  final <- run $ do+    w <- initWorld+    dones <- replicateM nThreads newEmptyMVar+    flip runSystem w $ do+      forM_ dones $ \done -> STM.forkSys $ do+        forM_ [1 .. perThread] $ \_ ->+          STM.atomically $ modify global (\(GlobalSum s) -> GlobalSum (s + 1))+        liftIO $ putMVar done ()+      liftIO $ mapM_ takeMVar dones+    runSystem (get global) w+  let GlobalSum gs = final+  assert $ getSum gs == nThreads * perThread++-- Mixed IO/STM world --------------------------------------------------------++{- | Within one IO system, drive the cached 'Map' directly while routing+transactional reads and writes of the STM 'STM.TMap' through @atomically@.+Both stores are keyed by the same 'Entity', demonstrating that the two store+families coexist in a single world.+-}+prop_mixedRoundtrip :: Entity -> CachedInt -> MapInt -> Property+prop_mixedRoundtrip e cv mv = assertSys initMixedWorld $ do+  -- Cached Map: plain IO access.+  set e cv+  -- STM TMap: writes must happen inside a transaction.+  STM.atomically $ set e mv+  cv' <- get e -- read back from the cached Map (IO)+  exC <- exists e (Proxy @CachedInt)+  (mv', exM) <- STM.atomically $ do+    -- read back from the TMap (STM)+    v <- get e+    ex <- exists e (Proxy @MapInt)+    pure (v, ex)+  pure $ cv == cv' && mv == mv' && exC && exM++{- | Many threads concurrently allocate entities and populate the STM 'TMap'+inside transactions; the IO-backed 'EntityCounter' keeps ids unique. Afterwards+the main thread, back in IO, decorates every spawned entity with a 'CachedInt'+in the cached 'Map' — a store the worker transactions could not have touched.+-}+prop_mixedConcurrentSpawn :: Property+prop_mixedConcurrentSpawn = once $ monadicIO $ do+  let+    nThreads = 6+    perThread = 100+  (uniqueIds, mapCount, cacheCount) <- run $ do+    w <- initMixedWorld+    collected <- C.newTVarIO ([] :: [Int])+    dones <- replicateM nThreads newEmptyMVar+    flip runSystem w $ do+      forM_ dones $ \done -> STM.forkSys $ do+        forM_ [1 .. perThread] $ \_ -> do+          Entity e <- STM.atomically (STM.newEntity (MapInt 7))+          liftIO $ C.atomically $ C.modifyTVar' collected (e :)+        liftIO $ putMVar done ()+      liftIO $ mapM_ takeMVar dones+    ids <- C.atomically (C.readTVar collected)+    -- Back in IO: give each spawned entity a cached-Map component.+    flip runSystem w $ forM_ ids $ \e -> set (Entity e) (CachedInt e)+    mc <- runSystem (cfold (\acc (_ :: MapInt, _ :: Entity) -> acc + 1) (0 :: Int)) w+    cc <- runSystem (cfold (\acc (_ :: CachedInt, _ :: Entity) -> acc + 1) (0 :: Int)) w+    pure (length (nub ids), mc, cc)+  assert $+    uniqueIds == nThreads * perThread+      && mapCount == uniqueIds+      && cacheCount == uniqueIds++-- ---------------------------------------------------------------------------++return []+main :: IO Bool+main = $quickCheckAll