module Symbolize
(
Symbol,
intern,
unintern,
lookup,
Textual (..),
GlobalSymbolTable,
globalSymbolTable,
globalSymbolTableSize,
)
where
import Control.Applicative ((<|>))
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as MVar
import Control.DeepSeq (NFData (..))
import Data.Function ((&))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Hashable (Hashable (..))
import Data.IORef (IORef)
import qualified Data.IORef as IORef
import Data.String (IsString (..))
import Data.Text.Display (Display (..))
import Data.Text.Short (ShortText)
import GHC.Read (Read (..))
import qualified Symbolize.Accursed
import Symbolize.Textual (Textual (..))
import qualified System.IO.Unsafe
import System.Mem.Weak (Weak)
import qualified System.Mem.Weak as Weak
import Text.Read (Lexeme (Ident), lexP, parens, prec, readListPrecDefault)
import qualified Text.Read
import Prelude hiding (lookup)
data Symbol = Symbol {-# UNPACK #-} !Word
instance Show Symbol where
showsPrec :: Int -> Symbol -> ShowS
showsPrec Int
p Symbol
symbol =
let !str :: [Char]
str = forall s. Textual s => Symbol -> s
unintern @String Symbol
symbol
in Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
[Char] -> ShowS
showString [Char]
"Symbolize.intern " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows [Char]
str
instance Read Symbol where
readListPrec :: ReadPrec [Symbol]
readListPrec = forall a. Read a => ReadPrec [a]
readListPrecDefault
readPrec :: ReadPrec Symbol
readPrec = forall a. ReadPrec a -> ReadPrec a
parens forall a b. (a -> b) -> a -> b
$ forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 forall a b. (a -> b) -> a -> b
$ ReadPrec Symbol
full forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadPrec Symbol
onlyString
where
onlyString :: ReadPrec Symbol
onlyString = do
[Char]
str <- forall a. Read a => ReadPrec a
readPrec @String
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. Textual s => s -> Symbol
Symbolize.intern [Char]
str
full :: ReadPrec Symbol
full = do
Ident [Char]
"Symbolize" <- ReadPrec Lexeme
lexP
Text.Read.Symbol [Char]
"." <- ReadPrec Lexeme
lexP
Ident [Char]
"intern" <- ReadPrec Lexeme
lexP
[Char]
str <- forall a. Read a => ReadPrec a
readPrec @String
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. Textual s => s -> Symbol
Symbolize.intern [Char]
str
instance IsString Symbol where
fromString :: [Char] -> Symbol
fromString = forall s. Textual s => s -> Symbol
intern
{-# INLINE fromString #-}
instance Display Symbol where
displayBuilder :: Symbol -> Builder
displayBuilder = forall s. Textual s => Symbol -> s
unintern
{-# INLINE displayBuilder #-}
instance Eq Symbol where
(Symbol Word
a) == :: Symbol -> Symbol -> Bool
== (Symbol Word
b) = Word
a forall a. Eq a => a -> a -> Bool
== Word
b
{-# INLINE (==) #-}
instance NFData Symbol where
rnf :: Symbol -> ()
rnf Symbol
sym = seq :: forall a b. a -> b -> b
seq Symbol
sym ()
instance Ord Symbol where
compare :: Symbol -> Symbol -> Ordering
compare Symbol
a Symbol
b = forall a. Ord a => a -> a -> Ordering
compare (forall s. Textual s => Symbol -> s
unintern @ShortText Symbol
a) (forall s. Textual s => Symbol -> s
unintern @ShortText Symbol
b)
{-# INLINE compare #-}
instance Hashable Symbol where
hash :: Symbol -> Int
hash (Symbol Word
idx) = forall a. Hashable a => a -> Int
hash Word
idx
hashWithSalt :: Int -> Symbol -> Int
hashWithSalt Int
salt (Symbol Word
idx) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt Word
idx
{-# INLINE hash #-}
{-# INLINE hashWithSalt #-}
data GlobalSymbolTable = GlobalSymbolTable
{ GlobalSymbolTable -> MVar Word
next :: !(MVar Word),
GlobalSymbolTable -> IORef SymbolTableMappings
mappings :: !(IORef SymbolTableMappings)
}
instance Show GlobalSymbolTable where
show :: GlobalSymbolTable -> [Char]
show GlobalSymbolTable
table =
forall a. IO a -> a
System.IO.Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
!Word
next' <- forall a. MVar a -> IO a
MVar.readMVar (GlobalSymbolTable -> MVar Word
next GlobalSymbolTable
table)
!SymbolTableMappings
mappings' <- forall a. IORef a -> IO a
IORef.readIORef (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
table)
let !contents :: HashMap Word ShortText
contents = SymbolTableMappings
mappings' forall a b. a -> (a -> b) -> b
& SymbolTableMappings -> HashMap Word ShortText
symbolsToText
let !count :: Int
count = forall k v. HashMap k v -> Int
HashMap.size HashMap Word ShortText
contents
forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall a b. (a -> b) -> a -> b
$ [Char]
"GlobalSymbolTable { count = "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
count
forall a. Semigroup a => a -> a -> a
<> [Char]
", next = "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word
next'
forall a. Semigroup a => a -> a -> a
<> [Char]
", contents = "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Word ShortText
contents)
forall a. Semigroup a => a -> a -> a
<> [Char]
" }"
data SymbolTableMappings = SymbolTableMappings
{ SymbolTableMappings -> Map ShortText (Weak Symbol)
textToSymbols :: !(Map ShortText (Weak Symbol)),
SymbolTableMappings -> HashMap Word ShortText
symbolsToText :: !(HashMap Word ShortText)
}
unintern :: (Textual s) => Symbol -> s
unintern :: forall s. Textual s => Symbol -> s
unintern (Symbol Word
idx) =
let !mappingsRef :: IORef SymbolTableMappings
mappingsRef = GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
globalSymbolTable'
!mappings' :: SymbolTableMappings
mappings' = forall a. IO a -> a
Symbolize.Accursed.accursedUnutterablePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
IORef.readIORef IORef SymbolTableMappings
mappingsRef
in SymbolTableMappings
mappings'
forall a b. a -> (a -> b) -> b
& SymbolTableMappings -> HashMap Word ShortText
symbolsToText
forall a b. a -> (a -> b) -> b
& forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Word
idx
forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"Symbol " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word
idx forall a. Semigroup a => a -> a -> a
<> [Char]
" not found. This should never happen" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show GlobalSymbolTable
globalSymbolTable')) forall a. Textual a => ShortText -> a
fromShortText
{-# INLINE unintern #-}
lookup :: (Textual s) => s -> IO (Maybe Symbol)
lookup :: forall s. Textual s => s -> IO (Maybe Symbol)
lookup s
text = do
let !text' :: ShortText
text' = forall a. Textual a => a -> ShortText
toShortText s
text
GlobalSymbolTable
table <- IO GlobalSymbolTable
globalSymbolTable
SymbolTableMappings
mappings <- forall a. IORef a -> IO a
IORef.readIORef (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
table)
let maybeWeak :: Maybe (Weak Symbol)
maybeWeak = SymbolTableMappings
mappings forall a b. a -> (a -> b) -> b
& SymbolTableMappings -> Map ShortText (Weak Symbol)
textToSymbols forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ShortText
text'
case Maybe (Weak Symbol)
maybeWeak of
Maybe (Weak Symbol)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just Weak Symbol
weak -> do
forall v. Weak v -> IO (Maybe v)
Weak.deRefWeak Weak Symbol
weak
intern :: (Textual s) => s -> Symbol
intern :: forall s. Textual s => s -> Symbol
intern s
text =
let !text' :: ShortText
text' = forall a. Textual a => a -> ShortText
toShortText s
text
in ShortText -> Symbol
lookupOrInsert ShortText
text'
where
lookupOrInsert :: ShortText -> Symbol
lookupOrInsert ShortText
text' =
forall a. IO a -> a
System.IO.Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar (GlobalSymbolTable -> MVar Word
next GlobalSymbolTable
globalSymbolTable') forall a b. (a -> b) -> a -> b
$ \Word
next -> do
Maybe Symbol
maybeWeak <- forall s. Textual s => s -> IO (Maybe Symbol)
lookup s
text
case Maybe Symbol
maybeWeak of
Just Symbol
symbol -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
next, Symbol
symbol)
Maybe Symbol
Nothing -> ShortText -> Word -> IO (Word, Symbol)
insert ShortText
text' Word
next
insert :: ShortText -> Word -> IO (Word, Symbol)
insert ShortText
text' Word
next = do
SymbolTableMappings {HashMap Word ShortText
symbolsToText :: HashMap Word ShortText
symbolsToText :: SymbolTableMappings -> HashMap Word ShortText
symbolsToText, Map ShortText (Weak Symbol)
textToSymbols :: Map ShortText (Weak Symbol)
textToSymbols :: SymbolTableMappings -> Map ShortText (Weak Symbol)
textToSymbols} <- forall a. IORef a -> IO a
IORef.readIORef (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
globalSymbolTable')
let !idx :: Word
idx = Word -> HashMap Word ShortText -> Word
nextEmptyIndex Word
next HashMap Word ShortText
symbolsToText
let !symbol :: Symbol
symbol = Word -> Symbol
Symbol Word
idx
Weak Symbol
weakSymbol <- forall k. k -> Maybe (IO ()) -> IO (Weak k)
Weak.mkWeakPtr Symbol
symbol (forall a. a -> Maybe a
Just (Word -> IO ()
finalizer Word
idx))
let !mappings2 :: SymbolTableMappings
mappings2 =
SymbolTableMappings
{ symbolsToText :: HashMap Word ShortText
symbolsToText = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Word
idx ShortText
text' HashMap Word ShortText
symbolsToText,
textToSymbols :: Map ShortText (Weak Symbol)
textToSymbols = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ShortText
text' Weak Symbol
weakSymbol Map ShortText (Weak Symbol)
textToSymbols
}
forall a. IORef a -> a -> IO ()
IORef.atomicWriteIORef (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
globalSymbolTable') SymbolTableMappings
mappings2
let !nextFree :: Word
nextFree = Word
idx forall a. Num a => a -> a -> a
+ Word
1
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
nextFree, Symbol
symbol)
{-# INLINE intern #-}
nextEmptyIndex :: Word -> HashMap Word ShortText -> Word
nextEmptyIndex :: Word -> HashMap Word ShortText -> Word
nextEmptyIndex Word
starting HashMap Word ShortText
symbolsToText = Word -> Word
go Word
starting
where
go :: Word -> Word
go Word
idx = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Word
idx HashMap Word ShortText
symbolsToText of
Maybe ShortText
Nothing -> Word
idx
Maybe ShortText
_ -> Word -> Word
go (Word
idx forall a. Num a => a -> a -> a
+ Word
1)
globalSymbolTable :: IO GlobalSymbolTable
globalSymbolTable :: IO GlobalSymbolTable
globalSymbolTable =
GlobalSymbolTable
globalSymbolTable'
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a. Applicative f => a -> f a
pure
globalSymbolTable' :: GlobalSymbolTable
globalSymbolTable' :: GlobalSymbolTable
globalSymbolTable' =
forall a. IO a -> a
System.IO.Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
MVar Word
nextRef <- forall a. a -> IO (MVar a)
MVar.newMVar Word
0
IORef SymbolTableMappings
mappingsRef <- forall a. a -> IO (IORef a)
IORef.newIORef (Map ShortText (Weak Symbol)
-> HashMap Word ShortText -> SymbolTableMappings
SymbolTableMappings forall k a. Map k a
Map.empty forall k v. HashMap k v
HashMap.empty)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar Word -> IORef SymbolTableMappings -> GlobalSymbolTable
GlobalSymbolTable MVar Word
nextRef IORef SymbolTableMappings
mappingsRef)
{-# NOINLINE globalSymbolTable' #-}
globalSymbolTableSize :: IO Word
globalSymbolTableSize :: IO Word
globalSymbolTableSize = do
GlobalSymbolTable
table <- IO GlobalSymbolTable
globalSymbolTable
SymbolTableMappings
mappings <- forall a. IORef a -> IO a
IORef.readIORef (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
table)
let size :: Word
size =
SymbolTableMappings
mappings
forall a b. a -> (a -> b) -> b
& SymbolTableMappings -> HashMap Word ShortText
symbolsToText
forall a b. a -> (a -> b) -> b
& forall k v. HashMap k v -> Int
HashMap.size
forall a b. a -> (a -> b) -> b
& forall a b. (Integral a, Num b) => a -> b
fromIntegral
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
size
finalizer :: Word -> IO ()
finalizer :: Word -> IO ()
finalizer Word
idx = do
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar (GlobalSymbolTable -> MVar Word
next GlobalSymbolTable
globalSymbolTable') forall a b. (a -> b) -> a -> b
$ \Word
_next -> do
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' (GlobalSymbolTable -> IORef SymbolTableMappings
mappings GlobalSymbolTable
globalSymbolTable') forall a b. (a -> b) -> a -> b
$ \SymbolTableMappings {HashMap Word ShortText
symbolsToText :: HashMap Word ShortText
symbolsToText :: SymbolTableMappings -> HashMap Word ShortText
symbolsToText, Map ShortText (Weak Symbol)
textToSymbols :: Map ShortText (Weak Symbol)
textToSymbols :: SymbolTableMappings -> Map ShortText (Weak Symbol)
textToSymbols} ->
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Word
idx HashMap Word ShortText
symbolsToText of
Maybe ShortText
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Duplicate finalizer called for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word
idx forall a. Semigroup a => a -> a -> a
<> [Char]
"This should never happen")
Just ShortText
text ->
SymbolTableMappings
{ symbolsToText :: HashMap Word ShortText
symbolsToText = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete Word
idx HashMap Word ShortText
symbolsToText,
textToSymbols :: Map ShortText (Weak Symbol)
textToSymbols = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ShortText
text Map ShortText (Weak Symbol)
textToSymbols
}
{-# NOINLINE finalizer #-}