{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, MagicHash, RoleAnnotations, CPP #-}
module Data.Label(Label, unsafeMkLabel, labelNum, label, find) where
import Data.IORef
import System.IO.Unsafe
import qualified Data.Map.Strict as Map
import Data.Map.Strict(Map)
import qualified Data.DynamicArray as DynamicArray
import Data.DynamicArray(Array)
import Data.Typeable
import GHC.Exts
import GHC.Int
import Unsafe.Coerce
newtype Label a =
Label {
forall a. Label a -> Int32
labelNum :: Int32 }
deriving (Label a -> Label a -> Bool
forall a. Label a -> Label a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Label a -> Label a -> Bool
$c/= :: forall a. Label a -> Label a -> Bool
== :: Label a -> Label a -> Bool
$c== :: forall a. Label a -> Label a -> Bool
Eq, Label a -> Label a -> Bool
Label a -> Label a -> Ordering
Label a -> Label a -> Label a
forall a. Eq (Label a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Label a -> Label a -> Bool
forall a. Label a -> Label a -> Ordering
forall a. Label a -> Label a -> Label a
min :: Label a -> Label a -> Label a
$cmin :: forall a. Label a -> Label a -> Label a
max :: Label a -> Label a -> Label a
$cmax :: forall a. Label a -> Label a -> Label a
>= :: Label a -> Label a -> Bool
$c>= :: forall a. Label a -> Label a -> Bool
> :: Label a -> Label a -> Bool
$c> :: forall a. Label a -> Label a -> Bool
<= :: Label a -> Label a -> Bool
$c<= :: forall a. Label a -> Label a -> Bool
< :: Label a -> Label a -> Bool
$c< :: forall a. Label a -> Label a -> Bool
compare :: Label a -> Label a -> Ordering
$ccompare :: forall a. Label a -> Label a -> Ordering
Ord, Int -> Label a -> ShowS
forall a. Int -> Label a -> ShowS
forall a. [Label a] -> ShowS
forall a. Label a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Label a] -> ShowS
$cshowList :: forall a. [Label a] -> ShowS
show :: Label a -> String
$cshow :: forall a. Label a -> String
showsPrec :: Int -> Label a -> ShowS
$cshowsPrec :: forall a. Int -> Label a -> ShowS
Show)
type role Label nominal
unsafeMkLabel :: Int32 -> Label a
unsafeMkLabel :: forall a. Int32 -> Label a
unsafeMkLabel = forall a. Int32 -> Label a
Label
{-# NOINLINE cachesRef #-}
cachesRef :: IORef Caches
cachesRef :: IORef Caches
cachesRef = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef (Int32 -> Map TypeRep (Cache Any) -> Array Any -> Caches
Caches Int32
0 forall k a. Map k a
Map.empty forall a. Array a
DynamicArray.newArray))
data Caches =
Caches {
Caches -> Int32
caches_nextId :: {-# UNPACK #-} !Int32,
Caches -> Map TypeRep (Cache Any)
caches_from :: !(Map TypeRep (Cache Any)),
Caches -> Array Any
caches_to :: !(Array Any) }
type Cache a = Map a Int32
atomicModifyCaches :: (Caches -> (Caches, a)) -> IO a
atomicModifyCaches :: forall a. (Caches -> (Caches, a)) -> IO a
atomicModifyCaches Caches -> (Caches, a)
f = do
!Caches
caches <- forall a. IORef a -> IO a
readIORef IORef Caches
cachesRef
let !(!Caches
caches', !a
x) = Caches -> (Caches, a)
f Caches
caches
Bool
ok <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Caches
cachesRef forall a b. (a -> b) -> a -> b
$ \Caches
cachesNow ->
if Caches -> Int32
caches_nextId Caches
caches forall a. Eq a => a -> a -> Bool
== Caches -> Int32
caches_nextId Caches
cachesNow
then (Caches
caches', Bool
True)
else (Caches
cachesNow, Bool
False)
if Bool
ok then forall (m :: * -> *) a. Monad m => a -> m a
return a
x else forall a. (Caches -> (Caches, a)) -> IO a
atomicModifyCaches Caches -> (Caches, a)
f
toAnyCache :: Cache a -> Cache Any
toAnyCache :: forall a. Cache a -> Cache Any
toAnyCache = forall a b. a -> b
unsafeCoerce
fromAnyCache :: Cache Any -> Cache a
fromAnyCache :: forall a. Cache Any -> Cache a
fromAnyCache = forall a b. a -> b
unsafeCoerce
toAny :: a -> Any
toAny :: forall a. a -> Any
toAny = forall a b. a -> b
unsafeCoerce
fromAny :: Any -> a
fromAny :: forall a. Any -> a
fromAny = forall a b. a -> b
unsafeCoerce
{-# NOINLINE label #-}
label :: forall a. (Typeable a, Ord a) => a -> Label a
label :: forall a. (Typeable a, Ord a) => a -> Label a
label a
x =
forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
Caches
caches <- forall a. IORef a -> IO a
readIORef IORef Caches
cachesRef
case Caches -> Maybe (Label a)
tryFind Caches
caches of
Just Label a
l -> forall (m :: * -> *) a. Monad m => a -> m a
return Label a
l
Maybe (Label a)
Nothing -> do
Label a
x <- forall a. (Caches -> (Caches, a)) -> IO a
atomicModifyCaches forall a b. (a -> b) -> a -> b
$ \Caches
caches ->
case Caches -> Maybe (Label a)
tryFind Caches
caches of
Just Label a
l -> (Caches
caches, Label a
l)
Maybe (Label a)
Nothing ->
Caches -> (Caches, Label a)
insert Caches
caches
forall (m :: * -> *) a. Monad m => a -> m a
return Label a
x
where
ty :: TypeRep
ty = forall a. Typeable a => a -> TypeRep
typeOf a
x
tryFind :: Caches -> Maybe (Label a)
tryFind :: Caches -> Maybe (Label a)
tryFind Caches{Int32
Map TypeRep (Cache Any)
Array Any
caches_to :: Array Any
caches_from :: Map TypeRep (Cache Any)
caches_nextId :: Int32
caches_to :: Caches -> Array Any
caches_from :: Caches -> Map TypeRep (Cache Any)
caches_nextId :: Caches -> Int32
..} =
forall a. Int32 -> Label a
Label forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
ty Map TypeRep (Cache Any)
caches_from forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Cache Any -> Cache a
fromAnyCache)
insert :: Caches -> (Caches, Label a)
insert :: Caches -> (Caches, Label a)
insert caches :: Caches
caches@Caches{Int32
Map TypeRep (Cache Any)
Array Any
caches_to :: Array Any
caches_from :: Map TypeRep (Cache Any)
caches_nextId :: Int32
caches_to :: Caches -> Array Any
caches_from :: Caches -> Map TypeRep (Cache Any)
caches_nextId :: Caches -> Int32
..} =
if Int32
n forall a. Ord a => a -> a -> Bool
< Int32
0 then forall a. HasCallStack => String -> a
error String
"label overflow" else
(Caches
caches {
caches_nextId :: Int32
caches_nextId = Int32
nforall a. Num a => a -> a -> a
+Int32
1,
caches_from :: Map TypeRep (Cache Any)
caches_from = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeRep
ty (forall a. Cache a -> Cache Any
toAnyCache (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
x Int32
n forall {a}. Cache a
cache)) Map TypeRep (Cache Any)
caches_from,
caches_to :: Array Any
caches_to = forall a. a -> Int -> a -> Array a -> Array a
DynamicArray.updateWithDefault forall a. HasCallStack => a
undefined (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) (forall a. a -> Any
toAny a
x) Array Any
caches_to },
forall a. Int32 -> Label a
Label Int32
n)
where
n :: Int32
n = Int32
caches_nextId
cache :: Cache a
cache =
forall a. Cache Any -> Cache a
fromAnyCache forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty TypeRep
ty Map TypeRep (Cache Any)
caches_from
find :: Label a -> a
find :: forall a. Label a -> a
find (Label !(I32# Int32#
n#)) = forall a. Int32# -> a
findWorker Int32#
n#
{-# NOINLINE findWorker #-}
#if __GLASGOW_HASKELL__ >= 902
findWorker :: Int32# -> a
#else
findWorker :: Int# -> a
#endif
findWorker :: forall a. Int32# -> a
findWorker Int32#
n# =
forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
let n :: Int32
n = Int32# -> Int32
I32# Int32#
n#
Caches{Int32
Map TypeRep (Cache Any)
Array Any
caches_to :: Array Any
caches_from :: Map TypeRep (Cache Any)
caches_nextId :: Int32
caches_to :: Caches -> Array Any
caches_from :: Caches -> Map TypeRep (Cache Any)
caches_nextId :: Caches -> Int32
..} <- forall a. IORef a -> IO a
readIORef IORef Caches
cachesRef
a
x <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Any -> a
fromAny (forall a. a -> Int -> Array a -> a
DynamicArray.getWithDefault forall a. HasCallStack => a
undefined (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) Array Any
caches_to)
forall (m :: * -> *) a. Monad m => a -> m a
return a
x