{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-cse #-}

-- |
-- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches
-- Copyright   :   (c) Sirui Lu 2021-2023
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
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 #-}