diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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`.
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+
 main = defaultMain
diff --git a/apecs-stm.cabal b/apecs-stm.cabal
--- a/apecs-stm.cabal
+++ b/apecs-stm.cabal
@@ -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"
diff --git a/bench/Main.hs b/bench/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Main.hs
@@ -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)))
+        ]
+    ]
diff --git a/src/Apecs/STM.hs b/src/Apecs/STM.hs
deleted file mode 100644
--- a/src/Apecs/STM.hs
+++ /dev/null
@@ -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
diff --git a/src/Apecs/STM/Prelude.hs b/src/Apecs/STM/Prelude.hs
deleted file mode 100644
--- a/src/Apecs/STM/Prelude.hs
+++ /dev/null
@@ -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
diff --git a/src/Apecs/Stores/STM.hs b/src/Apecs/Stores/STM.hs
new file mode 100644
--- /dev/null
+++ b/src/Apecs/Stores/STM.hs
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -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