{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-cse #-}
module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches (typeMemoizedCache) where
import Control.Concurrent
import Data.Data
import qualified Data.HashMap.Strict as M
import Data.IORef
import Data.Interned
import GHC.Base (Any)
import GHC.IO
import Unsafe.Coerce
mkOnceIO :: IO a -> IO (IO a)
mkOnceIO :: forall a. IO a -> IO (IO a)
mkOnceIO IO a
io = do
MVar a
mv <- forall a. IO (MVar a)
newEmptyMVar
MVar ()
demand <- forall a. IO (MVar a)
newEmptyMVar
IO () -> IO ThreadId
forkIO (forall a. MVar a -> IO a
takeMVar MVar ()
demand forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
io forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar a
mv)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
demand () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. MVar a -> IO a
readMVar MVar a
mv)
termCacheCell :: IO (IORef (M.HashMap TypeRep Any))
termCacheCell :: IO (IORef (HashMap TypeRep Any))
termCacheCell = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (IO a)
mkOnceIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall k v. HashMap k v
M.empty
{-# NOINLINE termCacheCell #-}
typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a
typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a
typeMemoizedCache = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
IORef (HashMap TypeRep Any)
c <- IO (IORef (HashMap TypeRep Any))
termCacheCell
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap TypeRep Any)
c forall a b. (a -> b) -> a -> b
$ \HashMap TypeRep Any
m ->
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)) HashMap TypeRep Any
m of
Just Any
d -> (HashMap TypeRep Any
m, forall a b. a -> b
unsafeCoerce Any
d)
Maybe Any
Nothing -> (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)) (forall a b. a -> b
unsafeCoerce Cache a
r1) HashMap TypeRep Any
m, Cache a
r1)
where
r1 :: Cache a
!r1 :: Cache a
r1 = forall t. Interned t => Cache t
mkCache
{-# NOINLINE r1 #-}