{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- 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.Once
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

termCacheCell :: IO (IORef (M.HashMap TypeRep Any))
termCacheCell :: IO (IORef (HashMap TypeRep Any))
termCacheCell = IO (IO (IORef (HashMap TypeRep Any)))
-> IO (IORef (HashMap TypeRep Any))
forall a. IO a -> a
unsafeDupablePerformIO (IO (IO (IORef (HashMap TypeRep Any)))
 -> IO (IORef (HashMap TypeRep Any)))
-> IO (IO (IORef (HashMap TypeRep Any)))
-> IO (IORef (HashMap TypeRep Any))
forall a b. (a -> b) -> a -> b
$ IO (IORef (HashMap TypeRep Any))
-> IO (IO (IORef (HashMap TypeRep Any)))
forall a. Once a => a -> IO a
once (IO (IORef (HashMap TypeRep Any))
 -> IO (IO (IORef (HashMap TypeRep Any))))
-> IO (IORef (HashMap TypeRep Any))
-> IO (IO (IORef (HashMap TypeRep Any)))
forall a b. (a -> b) -> a -> b
$ HashMap TypeRep Any -> IO (IORef (HashMap TypeRep Any))
forall a. a -> IO (IORef a)
newIORef HashMap TypeRep Any
forall k v. HashMap k v
M.empty

typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a
typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a
typeMemoizedCache = IO (Cache a) -> Cache a
forall a. IO a -> a
unsafeDupablePerformIO (IO (Cache a) -> Cache a) -> IO (Cache a) -> Cache a
forall a b. (a -> b) -> a -> b
$ do
  IORef (HashMap TypeRep Any)
c <- IO (IORef (HashMap TypeRep Any))
termCacheCell
  IORef (HashMap TypeRep Any)
-> (HashMap TypeRep Any -> (HashMap TypeRep Any, Cache a))
-> IO (Cache a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap TypeRep Any)
c ((HashMap TypeRep Any -> (HashMap TypeRep Any, Cache a))
 -> IO (Cache a))
-> (HashMap TypeRep Any -> (HashMap TypeRep Any, Cache a))
-> IO (Cache a)
forall a b. (a -> b) -> a -> b
$ \HashMap TypeRep Any
m ->
    case TypeRep -> HashMap TypeRep Any -> Maybe Any
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) HashMap TypeRep Any
m of
      Just Any
d -> (HashMap TypeRep Any
m, Any -> Cache a
forall a b. a -> b
unsafeCoerce Any
d)
      Maybe Any
Nothing -> (TypeRep -> Any -> HashMap TypeRep Any -> HashMap TypeRep Any
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Cache a -> Any
forall a b. a -> b
unsafeCoerce Cache a
r1) HashMap TypeRep Any
m, Cache a
r1)
        where
          r1 :: Cache a
          !r1 :: Cache a
r1 = Cache a
forall t. Interned t => Cache t
mkCache
          {-# NOINLINE r1 #-}