{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.Stores
( Map, Cache, Unique,
Global,
Cachable,
ReadOnly, setReadOnly, destroyReadOnly
) where
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.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 GHC.TypeLits
import Apecs.Core
newtype Map c = Map (IORef (M.IntMap c))
type instance Elem (Map c) = c
instance MonadIO m => ExplInit m (Map c) where
explInit :: m (Map c)
explInit = IO (Map c) -> m (Map c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Map c) -> m (Map c)) -> IO (Map c) -> m (Map c)
forall a b. (a -> b) -> a -> b
$ IORef (IntMap c) -> Map c
forall c. IORef (IntMap c) -> Map c
Map (IORef (IntMap c) -> Map c) -> IO (IORef (IntMap c)) -> IO (Map c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap c -> IO (IORef (IntMap c))
forall a. a -> IO (IORef a)
newIORef IntMap c
forall a. Monoid a => a
mempty
instance (MonadIO m, Typeable c) => ExplGet m (Map c) where
explExists :: Map c -> Int -> m Bool
explExists (Map IORef (IntMap c)
ref) Int
ety = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap c -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
ety (IntMap c -> Bool) -> IO (IntMap c) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref
explGet :: Map c -> Int -> m (Elem (Map c))
explGet (Map IORef (IntMap c)
ref) Int
ety = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ ((Maybe c -> c) -> IO (Maybe c) -> IO c)
-> IO (Maybe c) -> (Maybe c -> c) -> IO c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe c -> c) -> IO (Maybe c) -> IO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> IntMap c -> Maybe c
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
ety (IntMap c -> Maybe c) -> IO (IntMap c) -> IO (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref) ((Maybe c -> c) -> IO c) -> (Maybe c -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ \case
Just c
c -> c
c
Maybe c
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
[ [Char]
"Reading non-existent Map component"
, TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe c -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe c
notFound)
, [Char]
"for entity"
, Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ety
]
{-# INLINE explExists #-}
{-# INLINE explGet #-}
instance MonadIO m => ExplSet m (Map c) where
{-# INLINE explSet #-}
explSet :: Map c -> Int -> Elem (Map c) -> m ()
explSet (Map IORef (IntMap c)
ref) Int
ety Elem (Map c)
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (IntMap c) -> (IntMap c -> IntMap c) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap c)
ref (Int -> c -> IntMap c -> IntMap c
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
ety c
Elem (Map c)
x)
instance MonadIO m => ExplDestroy m (Map c) where
{-# INLINE explDestroy #-}
explDestroy :: Map c -> Int -> m ()
explDestroy (Map IORef (IntMap c)
ref) Int
ety = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref IO (IntMap c) -> (IntMap c -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef (IntMap c) -> IntMap c -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap c)
ref (IntMap c -> IO ()) -> (IntMap c -> IntMap c) -> IntMap c -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap c -> IntMap c
forall a. Int -> IntMap a -> IntMap a
M.delete Int
ety
instance MonadIO m => ExplMembers m (Map c) where
{-# INLINE explMembers #-}
explMembers :: Map c -> m (Vector Int)
explMembers (Map IORef (IntMap c)
ref) = IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Vector Int) -> m (Vector Int))
-> IO (Vector Int) -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
U.fromList ([Int] -> Vector Int)
-> (IntMap c -> [Int]) -> IntMap c -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap c -> [Int]
forall a. IntMap a -> [Int]
M.keys (IntMap c -> Vector Int) -> IO (IntMap c) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref
newtype Unique c = Unique (IORef (Maybe (Int, c)))
type instance Elem (Unique c) = c
instance MonadIO m => ExplInit m (Unique c) where
explInit :: m (Unique c)
explInit = IO (Unique c) -> m (Unique c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Unique c) -> m (Unique c)) -> IO (Unique c) -> m (Unique c)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> Unique c
forall c. IORef (Maybe (Int, c)) -> Unique c
Unique (IORef (Maybe (Int, c)) -> Unique c)
-> IO (IORef (Maybe (Int, c))) -> IO (Unique c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, c) -> IO (IORef (Maybe (Int, c)))
forall a. a -> IO (IORef a)
newIORef Maybe (Int, c)
forall a. Maybe a
Nothing
instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where
{-# INLINE explGet #-}
explGet :: Unique c -> Int -> m (Elem (Unique c))
explGet (Unique IORef (Maybe (Int, c))
ref) Int
_ = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ ((Maybe (Int, c) -> c) -> IO (Maybe (Int, c)) -> IO c)
-> IO (Maybe (Int, c)) -> (Maybe (Int, c) -> c) -> IO c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> c) -> IO (Maybe (Int, c)) -> IO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref) ((Maybe (Int, c) -> c) -> IO c) -> (Maybe (Int, c) -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ \case
Just (Int
_, c
c) -> c
c
Maybe (Int, c)
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
[ [Char]
"Reading non-existent Unique component"
, TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (Int, c) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe (Int, c)
notFound)
]
{-# INLINE explExists #-}
explExists :: Unique c -> Int -> m Bool
explExists (Unique IORef (Maybe (Int, c))
ref) Int
ety = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> ((Int, c) -> Bool) -> Maybe (Int, c) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst) (Maybe (Int, c) -> Bool) -> IO (Maybe (Int, c)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref
instance MonadIO m => ExplSet m (Unique c) where
{-# INLINE explSet #-}
explSet :: Unique c -> Int -> Elem (Unique c) -> m ()
explSet (Unique IORef (Maybe (Int, c))
ref) Int
ety Elem (Unique c)
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> Maybe (Int, c) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, c))
ref ((Int, c) -> Maybe (Int, c)
forall a. a -> Maybe a
Just (Int
ety, c
Elem (Unique c)
c))
instance MonadIO m => ExplDestroy m (Unique c) where
{-# INLINE explDestroy #-}
explDestroy :: Unique c -> Int -> m ()
explDestroy (Unique IORef (Maybe (Int, c))
ref) Int
ety = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref IO (Maybe (Int, c)) -> (Maybe (Int, c) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
((Int, c) -> IO ()) -> Maybe (Int, c) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IORef (Maybe (Int, c)) -> Maybe (Int, c) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, c))
ref Maybe (Int, c)
forall a. Maybe a
Nothing) (Bool -> IO ()) -> ((Int, c) -> Bool) -> (Int, c) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst)
instance MonadIO m => ExplMembers m (Unique c) where
{-# INLINE explMembers #-}
explMembers :: Unique c -> m (Vector Int)
explMembers (Unique IORef (Maybe (Int, c))
ref) = IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Vector Int) -> m (Vector Int))
-> IO (Vector Int) -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$ ((Maybe (Int, c) -> Vector Int)
-> IO (Maybe (Int, c)) -> IO (Vector Int))
-> IO (Maybe (Int, c))
-> (Maybe (Int, c) -> Vector Int)
-> IO (Vector Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> Vector Int)
-> IO (Maybe (Int, c)) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref) ((Maybe (Int, c) -> Vector Int) -> IO (Vector Int))
-> (Maybe (Int, c) -> Vector Int) -> IO (Vector Int)
forall a b. (a -> b) -> a -> b
$ \case
Maybe (Int, c)
Nothing -> Vector Int
forall a. Monoid a => a
mempty
Just (Int
ety, c
_) -> Int -> Vector Int
forall a. Unbox a => a -> Vector a
U.singleton Int
ety
newtype Global c = Global (IORef c)
type instance Elem (Global c) = c
instance (Monoid c, MonadIO m) => ExplInit m (Global c) where
{-# INLINE explInit #-}
explInit :: m (Global c)
explInit = IO (Global c) -> m (Global c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Global c) -> m (Global c)) -> IO (Global c) -> m (Global c)
forall a b. (a -> b) -> a -> b
$ IORef c -> Global c
forall c. IORef c -> Global c
Global (IORef c -> Global c) -> IO (IORef c) -> IO (Global c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> IO (IORef c)
forall a. a -> IO (IORef a)
newIORef c
forall a. Monoid a => a
mempty
instance MonadIO m => ExplGet m (Global c) where
{-# INLINE explGet #-}
explGet :: Global c -> Int -> m (Elem (Global c))
explGet (Global IORef c
ref) Int
_ = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ IORef c -> IO c
forall a. IORef a -> IO a
readIORef IORef c
ref
{-# INLINE explExists #-}
explExists :: Global c -> Int -> m Bool
explExists Global c
_ Int
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
instance MonadIO m => ExplSet m (Global c) where
{-# INLINE explSet #-}
explSet :: Global c -> Int -> Elem (Global c) -> m ()
explSet (Global IORef c
ref) Int
_ Elem (Global c)
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef c -> c -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef c
ref c
Elem (Global c)
c
class Cachable s
instance Cachable (Map s)
instance (KnownNat n, Cachable s) => Cachable (Cache n s)
data Cache (n :: Nat) s =
Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s
cacheMiss :: t
cacheMiss :: t
cacheMiss = [Char] -> t
forall a. HasCallStack => [Char] -> a
error [Char]
"Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"
type instance Elem (Cache n s) = Elem s
instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where
{-# INLINE explInit #-}
explInit :: m (Cache n s)
explInit = do
let n :: Int
n = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n) :: Int
size :: Int
size = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> ([Int] -> [Int]) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n) ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int
1
mask :: Int
mask = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
IOVector Int
tags <- IO (IOVector Int) -> m (IOVector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (IOVector Int) -> m (IOVector Int))
-> IO (IOVector Int) -> m (IOVector Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IO (MVector (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
UM.replicate Int
size (-Int
2)
MVector RealWorld (Elem s)
cache <- IO (MVector RealWorld (Elem s)) -> m (MVector RealWorld (Elem s))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (MVector RealWorld (Elem s)) -> m (MVector RealWorld (Elem s)))
-> IO (MVector RealWorld (Elem s))
-> m (MVector RealWorld (Elem s))
forall a b. (a -> b) -> a -> b
$ Int -> Elem s -> IO (MVector (PrimState IO) (Elem s))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
VM.replicate Int
size Elem s
forall t. t
cacheMiss
s
child <- m s
forall (m :: * -> *) s. ExplInit m s => m s
explInit
Cache n s -> m (Cache n s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IOVector Int -> MVector RealWorld (Elem s) -> s -> Cache n s
forall (n :: Nat) s.
Int -> IOVector Int -> IOVector (Elem s) -> s -> Cache n s
Cache Int
mask IOVector Int
tags MVector RealWorld (Elem s)
cache s
child)
instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where
{-# INLINE explGet #-}
explGet :: Cache n s -> Int -> m (Elem (Cache n s))
explGet (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety = do
let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags Int
index
if Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety
then IO (Elem s) -> m (Elem s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Elem s) -> m (Elem s)) -> IO (Elem s) -> m (Elem s)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> IO (Elem s)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index
else s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s Int
ety
{-# INLINE explExists #-}
explExists :: Cache n s -> Int -> m Bool
explExists (Cache Int
mask IOVector Int
tags IOVector (Elem s)
_ s
s) Int
ety = do
Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
if Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s Int
ety
instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where
{-# INLINE explSet #-}
explSet :: Cache n s -> Int -> Elem (Cache n s) -> m ()
explSet (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety Elem (Cache n s)
x = do
let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags Int
index
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Int
2) Bool -> Bool -> Bool
&& Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ety) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Elem s
cached <- IO (Elem s) -> m (Elem s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Elem s) -> m (Elem s)) -> IO (Elem s) -> m (Elem s)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> IO (Elem s)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index
s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
tag Elem s
cached
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UM.unsafeWrite IOVector Int
MVector (PrimState IO) Int
tags Int
index Int
ety
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> Elem s -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index Elem s
Elem (Cache n s)
x
instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where
{-# INLINE explDestroy #-}
explDestroy :: Cache n s -> Int -> m ()
explDestroy (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety = do
let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
MVector (PrimState IO) Int -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UM.unsafeWrite IOVector Int
MVector (PrimState IO) Int
tags Int
index (-Int
2)
MVector (PrimState IO) (Elem s) -> Int -> Elem s -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index Elem s
forall t. t
cacheMiss
s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
ety
instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where
{-# INLINE explMembers #-}
explMembers :: Cache n s -> m (Vector Int)
explMembers (Cache Int
mask IOVector Int
tags IOVector (Elem s)
_ s
s) = do
Vector Int
cached <- IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Vector Int) -> m (Vector Int))
-> IO (Vector Int) -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Vector Int -> Vector Int
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
U.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Int
2)) (Vector Int -> Vector Int) -> IO (Vector Int) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Int -> IO (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
U.freeze IOVector Int
MVector (PrimState IO) Int
tags
let etyFilter :: Int -> IO Bool
etyFilter Int
ety = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ety) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
Vector Int
stored <- s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s m (Vector Int) -> (Vector Int -> m (Vector Int)) -> m (Vector Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector Int) -> m (Vector Int))
-> (Vector Int -> IO (Vector Int)) -> Vector Int -> m (Vector Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IO Bool) -> Vector Int -> IO (Vector Int)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(a -> m Bool) -> Vector a -> m (Vector a)
U.filterM Int -> IO Bool
etyFilter
Vector Int -> m (Vector Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Int -> m (Vector Int)) -> Vector Int -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$! Vector Int
cached Vector Int -> Vector Int -> Vector Int
forall a. Unbox a => Vector a -> Vector a -> Vector a
U.++ Vector Int
stored
newtype ReadOnly s = ReadOnly s
type instance Elem (ReadOnly s) = Elem s
instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where
explInit :: m (ReadOnly s)
explInit = s -> ReadOnly s
forall s. s -> ReadOnly s
ReadOnly (s -> ReadOnly s) -> m s -> m (ReadOnly s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall (m :: * -> *) s. ExplInit m s => m s
explInit
instance ExplGet m s => ExplGet m (ReadOnly s) where
explExists :: ReadOnly s -> Int -> m Bool
explExists (ReadOnly s
s) = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s
explGet :: ReadOnly s -> Int -> m (Elem (ReadOnly s))
explGet (ReadOnly s
s) = s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s
{-# INLINE explExists #-}
{-# INLINE explGet #-}
instance ExplMembers m s => ExplMembers m (ReadOnly s) where
{-# INLINE explMembers #-}
explMembers :: ReadOnly s -> m (Vector Int)
explMembers (ReadOnly s
s) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s
setReadOnly :: forall w m s c.
( Has w m c
, Storage c ~ ReadOnly s
, Elem s ~ c
, ExplSet m s
) => Entity -> c -> SystemT w m ()
setReadOnly :: Entity -> c -> SystemT w m ()
setReadOnly (Entity Int
ety) c
c = do
ReadOnly s
s <- SystemT w m (ReadOnly s)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
ety c
Elem s
c
destroyReadOnly :: forall w m s c.
( Has w m c
, Storage c ~ ReadOnly s
, Elem s ~ c
, ExplDestroy m s
) => Entity -> Proxy c -> SystemT w m ()
destroyReadOnly :: Entity -> Proxy c -> SystemT w m ()
destroyReadOnly (Entity Int
ety) Proxy c
_ = do
ReadOnly s :: Storage c <- SystemT w m (ReadOnly s)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
ety