module Twee.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.IntMap.Strict as IntMap
import Data.IntMap.Strict(IntMap)
import Data.Typeable
import GHC.Exts
import Unsafe.Coerce
import Data.Int
newtype Label a =
Label {
labelNum :: Int32 }
deriving (Eq, Ord, Show)
unsafeMkLabel :: Int32 -> Label a
unsafeMkLabel = Label
cachesRef :: IORef Caches
cachesRef = unsafePerformIO (newIORef (Caches 0 Map.empty IntMap.empty))
data Caches =
Caches {
caches_nextId :: !Int32,
caches_from :: !(Map TypeRep (Cache Any)),
caches_to :: !(IntMap Any) }
type Cache a = Map a Int32
atomicModifyCaches :: (Caches -> (Caches, a)) -> IO a
atomicModifyCaches f = do
!caches <- readIORef cachesRef
let !(!caches', !x) = f caches
ok <- atomicModifyIORef' cachesRef $ \cachesNow ->
if caches_nextId caches == caches_nextId cachesNow
then (caches', True)
else (cachesNow, False)
if ok then return x else atomicModifyCaches f
toAnyCache :: Cache a -> Cache Any
toAnyCache = unsafeCoerce
fromAnyCache :: Cache Any -> Cache a
fromAnyCache = unsafeCoerce
toAny :: a -> Any
toAny = unsafeCoerce
fromAny :: Any -> a
fromAny = unsafeCoerce
label :: forall a. (Typeable a, Ord a) => a -> Label a
label x =
unsafeDupablePerformIO $ do
caches <- readIORef cachesRef
case tryFind caches of
Just l -> return l
Nothing -> do
x <- atomicModifyCaches $ \caches ->
case tryFind caches of
Just l -> (caches, l)
Nothing ->
insert caches
return x
where
ty = typeOf x
tryFind :: Caches -> Maybe (Label a)
tryFind Caches{..} =
Label <$> (Map.lookup ty caches_from >>= Map.lookup x . fromAnyCache)
insert :: Caches -> (Caches, Label a)
insert caches@Caches{..} =
if n < 0 then error "label overflow" else
(caches {
caches_nextId = n+1,
caches_from = Map.insert ty (toAnyCache (Map.insert x n cache)) caches_from,
caches_to = IntMap.insert (fromIntegral n) (toAny x) caches_to },
Label n)
where
n = caches_nextId
cache =
fromAnyCache $
Map.findWithDefault Map.empty ty caches_from
find :: Label a -> a
find (Label !n) = unsafeDupablePerformIO $ do
Caches{..} <- readIORef cachesRef
x <- return $! fromAny (IntMap.findWithDefault undefined (fromIntegral n) caches_to)
return x