symbolize 0.1.0.3 → 1.0.0.0

raw patch · 7 files changed

+798/−255 lines, 7 filesdep +randomdep −text-displaydep −unordered-containersdep ~bytestringdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependencies removed: text-display, unordered-containers

Dependency ranges changed: bytestring, deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• src/Symbolize.hs +213/−224
• src/Symbolize/Accursed.hs +68/−5
• src/Symbolize/SipHash.hs +278/−0
• src/Symbolize/SymbolTable.hs +187/−0
• src/Symbolize/Textual.hs +14/−3
• symbolize.cabal +26/−23

@@ -12,6 +12,18 @@  (Note that the `symbolToText :: HashMap Word -> ShortText` is unaffected as its keys are not user-created and guaranteed unique.) - Remove NOINLINE for lookup as it is now a proper IO function. +## 1.0.0.0 - 2025-02-17++Completely overhauled implementation:+- The old implementation used `newtype Symbol = Symbol Word`, adding Weak-pointers to this `Word`.+  - This was brittle, since those `Word`s would often get inlined, potentially triggering weak-pointer finalization (too) early.+  - The symbol table had to keep track of mappings in both directions.+  - Int also meant that `unintern` required access to the symbol table.+- The new implementation uses `newtype Symbol# = Symbol# ByteArray#`, and adds weak pointers to this unlifted `ByteArray#`.+  - Much safer, this is how `mkWeak` is intended to be used.+  - The symbol table now only needs to store 'TextHash -> Weak Symbol', and is essentially just a 'weak hashset'. Less than half the memory usage!+  - Much faster `unintern`, as it no longer needs access to the symbol table but is a simple pointer dereference.+ ## 0.1.0.1 / 0.1.0.2 - 2023-11-24 Fixes in the README and package description only, for better rendering on Hackage. 

@@ -1,19 +1,27 @@+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedNewtypes #-}+ -- | Implementation of a global Symbol Table, with garbage collection. -- -- Symbols, also known as Atoms or Interned Strings, are a common technique -- to reduce memory usage and improve performance when using many small strings. ----- By storing a single copy of each encountered string in a global table and giving out indexes to that table,+-- By storing a single copy of each encountered string in a global table and giving out pointers to the stored keys, -- it is possible to compare strings for equality in constant time, instead of linear (in string size) time.+-- Furthermore, by using `StableName`, hashing of Symbols also takes constant-time, so `Symbol`s make great hashmap keys!. ----- The main advantages of Symbolize over existing symbol table implementations are:+-- The main advantages of Symbolize over other symbol table implementations are: -- -- - Garbage collection: Symbols which are no longer used are automatically cleaned up.--- - `Symbol`s have a memory footprint of exactly 1 `Word` and are nicely unpacked by GHC.--- - Support for any `Textual` type, including `String`, (strict and lazy) `Data.Text`, (strict and lazy) `Data.ByteString` etc.--- - Thread-safe.--- - Efficient: Calls to `lookup` and `unintern` are free of atomic memory barriers (and never have to wait on a concurrent thread running `intern`)--- - Support for a maximum of 2^64 symbols at the same time (you'll probably run out of memory before that point).+-- - Support for any `Textual` type, including `String`, (strict and lazy) `Data.Text`, (strict and lazy) `Data.ByteString`, `ShortText`, `ShortByteString`, etc.+-- - Great memory usage:+--    - `Symbol`s are simply a (lifted) wrapper around a `ByteArray#`, which is nicely unpacked by GHC.+--    - The symbol table is an `IntMap` that contains weak pointers to these same `ByteArray#`s and their associated `StableName#`s+-- - Great performance:+--   - `unintern` is a simple pointer-dereference+--   - calls to `lookup` are free of atomic memory barriers (and never have to wait on a concurrent thread running `intern`)+-- - Thread-safe -- -- == Basic usage --@@ -36,7 +44,7 @@ -- >>> niceCheeses -- [Symbolize.intern "Roquefort",Symbolize.intern "Camembert",Symbolize.intern "Brie"] ----- And if you are using OverloadedStrings, you can use the `IsString` instance to intern constants:+-- And if you are using `OverloadedStrings`, you can use the `IsString` instance to intern constants: -- -- >>> hello2 = ("hello" :: Symbol) -- >>> hello2@@ -62,15 +70,18 @@ -- Just (Symbolize.intern "hello") -- -- Symbols make great keys for `Data.HashMap` and `Data.HashSet`.--- Hashing them is a no-op and they are guaranteed to be unique:+-- Hashing them takes constant-time and they are guaranteed to be unique: -- -- >>> Data.Hashable.hash hello--- 0+-- 1+-- >>> Data.Hashable.hash world+-- 2 -- >>> fmap Data.Hashable.hash niceCheeses--- [2,3,4]+-- [3,4,5] -- -- For introspection, you can look at how many symbols currently exist: --+-- >>> System.Mem.performGC -- >>> Symbolize.globalSymbolTableSize -- 5 -- >>> [unintern (intern (show x)) | x <- [1..5]]@@ -88,74 +99,121 @@ -- /(Note that the exact format is subject to change.)/ -- -- >>> Symbolize.globalSymbolTable--- GlobalSymbolTable { count = 5, next = 10, contents = [(0,"hello"),(1,"world"),(2,"Roquefort"),(3,"Camembert"),(4,"Brie")] }+-- GlobalSymbolTable { size = 5, symbols = ["Brie","Camembert","Roquefort","hello","world"] } module Symbolize   ( -- * Symbol-    Symbol,+    Symbol (..),     intern,     unintern,     lookup,-    Textual (..),      -- * Introspection & Metrics-    GlobalSymbolTable,-    globalSymbolTable,-    globalSymbolTableSize,+    SymbolTable.GlobalSymbolTable,+    SymbolTable.globalSymbolTable,+    SymbolTable.globalSymbolTableSize,++    -- * manipulate unlifted Symbols directly+    Symbol#,+    intern#,+    intern##,+    unintern#,+    unintern##,+    sameSymbol#,+    sameSymbol##,+    hashSymbol#,+    hashSymbol##,+    compareSymbol#,   ) where  import Control.Applicative ((<|>))-import Control.Concurrent.MVar (MVar)-import qualified Control.Concurrent.MVar as MVar-import Control.DeepSeq (NFData (..))+import Control.DeepSeq (NFData (rnf))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Array.Byte (ByteArray (ByteArray))+import Data.ByteString.Short (ShortByteString (SBS)) 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 Data.Hashable (Hashable (hash, hashWithSalt))+import Data.String (IsString (fromString))+import Data.Text.Short qualified as Text.Short+import Data.Text.Short.Unsafe qualified as Text.Short.Unsafe+import GHC.Exts (ByteArray#, Int#, sameByteArray#)+import GHC.Int (Int (I#))+import Symbolize.Accursed qualified as Accursed+import Symbolize.SymbolTable qualified as SymbolTable+import Symbolize.Textual (Textual)+import Symbolize.Textual qualified as Textual+import Text.Read (Lexeme (Ident), Read (..), lexP, parens, prec, readListPrecDefault)+import Text.Read qualified import Prelude hiding (lookup)  -- | A string-like type with O(1) equality and comparison. ----- A Symbol represents a string (any `Textual`, so String, Text, ByteString etc.)--- However, it only stores an (unpacked) `Word`, used as index into a global table in which the actual string value is stored.--- Thus equality checks are constant-time, and its memory footprint is very low.+-- A Symbol represents a string (any `Textual`, so String, Text, ShortText, ByteString, ShortByteString, etc.) --+-- Just like `ShortText`, `ShortByteString` and `ByteArray`, a `Symbol` has an optimized memory representation,+-- directly wrapping a primitive `ByteArray#`.+--+-- Furthermore, a global symbol table keeps track of which values currently exist, ensuring we always deduplicate symbols.+-- This therefore allows us to:+-- - Check for equality between symbols in constant-time (using pointer equality)+-- - Calculate the hash in constant-time (using `StableName`)+-- - Keep the memory footprint of repeatedly-seen strings low.+-- -- This is very useful if you're frequently comparing strings -- and the same strings might come up many times.--- It also makes Symbol a great candidate for a key in a `HashMap` or `Data.HashSet`. (Hashing them is a no-op!)+-- It also makes Symbol a great candidate for a key in e.g. a `HashMap` or `HashSet`. ----- The symbol table is implemented using weak pointers,+-- The global symbol table is implemented using weak pointers, -- which means that unused symbols will be garbage collected.--- As such, you do not need to be concerned about memory leaks.+-- As such, you do not need to be concerned about memory leaks+-- (as is the case with many other symbol table implementations). -- -- Symbols are considered 'the same' regardless of whether they originate -- from a `String`, (lazy or strict, normal or short) `Data.Text`, (lazy or strict, normal or short) `Data.ByteString` etc.+data Symbol where+  Symbol :: Symbol# -> Symbol++-- | Unlifted version of `Symbol` ----- Symbolize supports up to 2^64 symbols existing at the same type.--- Your system will probably run out of memory before you reach that point.-data Symbol = Symbol {-# UNPACK #-} !Word+-- This is of kind `UnliftedType` (AKA `TYPE (BoxedRep Unlifted)`)+-- which means GHC knows it is already fully-evaluated+-- and can never contain bottoms.+--+-- In many cases, GHC is able to figure out+-- that the symbols you're using are already-evaluated+-- and will unbox them into `Symbol#`s automatically+-- behind the scenes.+--+-- However, in some cases, directly manipulating a `Symbol#`+-- can be beneficial, such as when storing them as keys or values+-- inside a collection that supports `UnliftedType`s.+--+-- A `Symbol#` has exactly the same in-memory representation+-- as a `ByteArray#` (It is an unlifted newtype around `ByteArray#`).+newtype Symbol# = Symbol# ByteArray# +-- | Equality checking takes only O(1) time, and is a simple pointer-equality check.+instance Eq Symbol where+  {-# INLINE (==) #-}+  (Symbol a) == (Symbol b) = a `sameSymbol#` b++-- | Symbols are ordered by their lexicographical UTF-8 representation.+--+-- Therefore, comparison takes O(n) time.+instance Ord Symbol where+  {-# INLINE compare #-}+  (Symbol a) `compare` (Symbol b) = a `compareSymbol#` b+ instance Show Symbol where   showsPrec p symbol =     let !str = unintern @String symbol      in showParen (p > 10) $           showString "Symbolize.intern " . shows str +instance IsString Symbol where+  {-# INLINE fromString #-}+  fromString = intern+ -- | To be a good citizen w.r.t both `Show` and `IsString`, reading is supported two ways: -- -- >>> read @Symbol "Symbolize.intern \"Haskell\""@@ -168,219 +226,150 @@     where       onlyString = do         str <- readPrec @String-        return $ Symbolize.intern str+        return $ intern str       full = do         Ident "Symbolize" <- lexP         Text.Read.Symbol "." <- lexP         Ident "intern" <- lexP         str <- readPrec @String-        return $ Symbolize.intern str--instance IsString Symbol where-  fromString = intern-  {-# INLINE fromString #-}---- |--- >>> Data.Text.Display.display (Symbolize.intern "Pizza")--- "Pizza"-instance Display Symbol where-  displayBuilder = unintern-  {-# INLINE displayBuilder #-}---- | Takes only O(1) time.-instance Eq Symbol where-  (Symbol a) == (Symbol b) = a == b-  {-# INLINE (==) #-}+        return $ intern str --- | Symbol contains only a strict `Word`, so it is already fully evaluated.+-- | The contents inside a `Symbol` are always guaranteed to be evaluated,+-- so this only forces the outernmost constructor using `seq`. instance NFData Symbol where-  rnf sym = seq sym ()---- | Symbols are ordered by their `ShortText` representation.------ Comparison takes O(n) time, as they are compared byte-by-byte.-instance Ord Symbol where-  compare a b = compare (unintern @ShortText a) (unintern @ShortText b)-  {-# INLINE compare #-}+  {-# INLINE rnf #-}+  rnf a = seq a ()  -- | -- Hashing a `Symbol` is very fast: ----- `hash` is a no-op and results in zero collissions, as `Symbol`'s index is unique and can be interpreted as a hash as-is.+-- `hash` takes O(1) and results in zero collissions, as `StableName`s are used. ----- `hashWithSalt` takes O(1) time; just as long as hashWithSalt-ing any other `Word`.+-- `hashWithSalt` takes O(1) time; just as long as hashWithSalt-ing any other `Int`. instance Hashable Symbol where-  hash (Symbol idx) = hash idx-  hashWithSalt salt (Symbol idx) = hashWithSalt salt idx   {-# INLINE hash #-}+  hash (Symbol s) = hashSymbol# s   {-# INLINE hashWithSalt #-}+  hashWithSalt salt (Symbol s) = hashWithSalt salt (hashSymbol# s) --- | The global Symbol Table, containing a bidirectional mapping between each symbol's textual representation and its Word index.+-- | Intern a string-like value. ----- You cannot manipulate the table itself directly,--- but you can use `globalSymbolTable` to get a handle to it and use its `Show` instance for introspection.+-- First converts the string to a `ShortText` (if it isn't already one).+-- See `Textual` for the type-specific time complexity of this. ----- `globalSymbolTableSize` can similarly be used to get the current size of the table.+-- Finally, it takes O(min(n, 64)) time to try to look up a matching symbol+-- and insert it if it did not exist yet+-- (where n is the number of symbols currently in the table). ----- Current implementation details (these might change even between PVP-compatible versions):--- --- - A (containers) `Map` is used for mapping text -> symbol. This has O(log2(n)) lookup time, but is resistent to HashDoS attacks.--- - A (unordered-containers) `HashMap` is used for mapping symbol -> text. This has O(log16(n)) lookup time. ---   Because symbols are unique and their values are not user-generated, there is no danger of HashDoS here.-data GlobalSymbolTable = GlobalSymbolTable-  { next :: !(MVar Word),-    mappings :: !(IORef SymbolTableMappings)-  }--instance Show GlobalSymbolTable where-  show table =-    -- SAFETY: We're only reading, and do not care about performance here.-    System.IO.Unsafe.unsafePerformIO $ do-      -- NOTE: We want to make sure that (roughly) the same table state is used for each of the components-      -- which is why we use BangPatterns such that a partially-read show string will end up printing a (roughly) consistent state.-      !next' <- MVar.readMVar (next table) -- IORef.readIORef (next table)-      !mappings' <- IORef.readIORef (mappings table)-      let !contents = mappings' & symbolsToText-      -- let !reverseContents = mappings' & textToSymbols & fmap  (fmap hash . System.IO.Unsafe.unsafePerformIO . Weak.deRefWeak) & HashMap.toList-      let !count = HashMap.size contents-      pure-        $ "GlobalSymbolTable { count = "-          <> show count-          <> ", next = "-          <> show next'-          -- <> ", reverseContents = "-          -- <> show reverseContents-          <> ", contents = "-          <> show (HashMap.toList contents)-          <> " }"+-- Any concurrent calls to (the critical section in) `intern` are synchronized.+intern :: (Textual str) => str -> Symbol+{-# INLINE intern #-}+intern !str = Symbol (intern# str) -data SymbolTableMappings = SymbolTableMappings-  { textToSymbols :: !(Map ShortText (Weak Symbol)),-    symbolsToText :: !(HashMap Word ShortText)-  }+-- | Version of `intern` that returns an unlifted `Symbol#`+intern# :: (Textual str) => str -> Symbol#+{-# INLINE intern# #-}+intern# !str = intern## (textualToBA# str) --- | Unintern a symbol, returning its textual value.--- Takes O(log16(n)) time to look up the matching textual value, where n is the number of symbols currently in the table.------ Afterwards, the textual value is converted to the desired type s. See `Textual` for the type-specific time complexity.------ Runs concurrently with any other operation on the symbol table, without any atomic memory barriers.-unintern :: (Textual s) => Symbol -> s-unintern (Symbol idx) =-  let !mappingsRef = mappings globalSymbolTable'-      -- SAFETY:-      -- First, it's thread-safe because we only read (from a single IORef).-      -- Second, this function is idempotent and (outwardly) pure,-      -- so whether it is executed only once or many times for a particular Symbol does not matter in the slightest.-      -- Thus, we're very happy with the compiler inlining, CSE'ing or floating out this IO action.-      ---      -- I hope I'm correct and the Cosmic Horror will not eat me!-      -- signed by Marten, 2023-11-24-      !mappings' = Symbolize.Accursed.accursedUnutterablePerformIO $ IORef.readIORef mappingsRef-   in mappings'-        & symbolsToText-        & HashMap.lookup idx-        & maybe (error ("Symbol " <> show idx <> " not found. This should never happen" <> show globalSymbolTable')) fromShortText-{-# INLINE unintern #-}+-- | Version of `intern` that directly works on an unlifted `ByteArray#` and returns an unlifted `Symbol#`+intern## :: ByteArray# -> Symbol#+{-# INLINE intern## #-}+intern## ba# =+  -- SAFETY: We're actually happy with let-floating/combining+  -- since the result is 'outwardly pure' and doing less work is better!+  let !(ByteArray ba2#) = Accursed.accursedUnutterablePerformIO (SymbolTable.insertGlobal ba#)+   in Symbol# ba2#  -- | Looks up a symbol in the global symbol table. -- -- Returns `Nothing` if no such symbol currently exists. ----- Takes O(log2(n)) time, where n is the number of symbols currently in the table.+-- First converts the string to a `ShortText` (if it isn't already one).+-- See `Textual` for the type-specific time complexity of this. --+-- Then, takes O(min(n, 64)) time, where n is the number of symbols currently in the table.+-- -- Runs concurrently with any other operation on the symbol table, without any atomic memory barriers. -- -- Because the result can vary depending on the current state of the symbol table, this function is not pure.-lookup :: (Textual s) => s -> IO (Maybe Symbol)-lookup text = do-  let !text' = toShortText text-  table <- globalSymbolTable-  mappings <- IORef.readIORef (mappings table)-  let maybeWeak = mappings & textToSymbols & Map.lookup text'-  case maybeWeak of-    Nothing -> pure Nothing-    Just weak -> do-      Weak.deRefWeak weak+lookup :: (Textual str, MonadIO m) => str -> m (Maybe Symbol)+{-# INLINE lookup #-}+lookup !str = lookup# (textualToBA# str) --- | Intern a string-like value.+-- | Version of `lookup` that directly works on an unlifted `ByteArray#`+lookup# :: (MonadIO m) => ByteArray# -> m (Maybe Symbol)+{-# INLINE lookup# #-}+lookup# ba# =+  liftIO $+    SymbolTable.lookupGlobal ba#+      & fmap (fmap (\(ByteArray ba2#) -> Symbol (Symbol# ba2#)))++-- | Unintern a symbol, returning its textual value. ----- First converts s to a `ShortText` (if it isn't already one). See `Textual` for the type-specific time complexity of this.--- Then, takes O(log2(n)) time to look up the matching symbol and insert it if it did not exist yet (where n is the number of symbols currently in the table).+-- Looking up the Symbol's textual value takes O(1) time, as we simply follow its internal pointer. ----- Any concurrent calls to (the critical section in) `intern` are synchronized.-intern :: (Textual s) => s -> Symbol-intern text =-  let !text' = toShortText text-   in lookupOrInsert text'-  where-    lookupOrInsert text' =-      -- SAFETY: `intern` is idempotent, so inlining and CSE is benign (and might indeed improve performance).-      System.IO.Unsafe.unsafePerformIO $ MVar.modifyMVar (next globalSymbolTable') $ \next -> do-        maybeWeak <- lookup text-        case maybeWeak of-          Just symbol -> pure (next, symbol)-          Nothing -> insert text' next-    insert text' next = do-      SymbolTableMappings {symbolsToText, textToSymbols} <- IORef.readIORef (mappings globalSymbolTable')-      let !idx = nextEmptyIndex next symbolsToText-      let !symbol = Symbol idx-      weakSymbol <- Weak.mkWeakPtr symbol (Just (finalizer idx))-      let !mappings2 =-            SymbolTableMappings-              { symbolsToText = HashMap.insert idx text' symbolsToText,-                textToSymbols = Map.insert text' weakSymbol textToSymbols-              }-      IORef.atomicWriteIORef (mappings globalSymbolTable') mappings2+-- Afterwards, the textual value is converted to the desired string type.+-- See `Textual` for the type-specific time complexity of this.+--+-- Does not use the symbol table, so runs fully concurrently with any other functions manipulating it.+unintern :: (Textual str) => Symbol -> str+{-# INLINE unintern #-}+unintern (Symbol sym#) = unintern# sym# -      let !nextFree = idx + 1-      pure (nextFree, symbol)-{-# INLINE intern #-}+-- | Version of `unintern` that works directly on an unlifted `Symbol#`+unintern# :: (Textual str) => Symbol# -> str+{-# INLINE unintern# #-}+unintern# (Symbol# ba#) = textualFromBA# ba# -nextEmptyIndex :: Word -> HashMap Word ShortText -> Word-nextEmptyIndex starting symbolsToText = go starting-  where-    go idx = case HashMap.lookup idx symbolsToText of-      Nothing -> idx-      _ -> go (idx + 1) -- <- Wrapping on overflow is intentional and important for correctness+-- | Version of `unintern` that works directly on an unlifted `Symbol#`+-- and returns the internal `ByteArray#+unintern## :: Symbol# -> ByteArray#+{-# INLINE unintern## #-}+unintern## (Symbol# ba#) = ba# --- | Returns a handle to the global symbol table. (Only) useful for introspection or debugging.-globalSymbolTable :: IO GlobalSymbolTable-globalSymbolTable =-  globalSymbolTable'-    -- re-introduce the IO bound which we unsafePerformIO'ed:-    & pure+-- | Equality checking on unlifted symbols.+--+-- This takes only O(1) time, and is a simple pointer-equality check.+sameSymbol# :: Symbol# -> Symbol# -> Bool+{-# INLINE sameSymbol# #-}+sameSymbol# a b =+  case sameSymbol## a b of+    0# -> False+    _ -> True -globalSymbolTable' :: GlobalSymbolTable-globalSymbolTable' =-  -- SAFETY: We need all calls to globalSymbolTable' to use the same thunk, so NOINLINE.-  System.IO.Unsafe.unsafePerformIO $ do-    nextRef <- MVar.newMVar 0 -- IORef.newIORef 0-    mappingsRef <- IORef.newIORef (SymbolTableMappings Map.empty HashMap.empty)-    return (GlobalSymbolTable nextRef mappingsRef)-{-# NOINLINE globalSymbolTable' #-}+-- | Version of `sameSymbol#` that returns the an `Int#`, an unlifted `Bool`+sameSymbol## :: Symbol# -> Symbol# -> Int#+{-# INLINE sameSymbol## #-}+sameSymbol## (Symbol# a) (Symbol# b) = sameByteArray# a b --- | Returns the current size of the global symbol table. Useful for introspection or metrics.-globalSymbolTableSize :: IO Word-globalSymbolTableSize = do-  table <- globalSymbolTable-  mappings <- IORef.readIORef (mappings table)-  let size =-        mappings-          & symbolsToText-          & HashMap.size-          & fromIntegral-  pure size+-- | Hash an unlifted `Symbol#`+--+-- Takes O(1) and results in zero collissions, as `StableName`s are used.+hashSymbol# :: Symbol# -> Int+{-# INLINE hashSymbol# #-}+hashSymbol# sym# = I# (hashSymbol## sym#) -finalizer :: Word -> IO ()-finalizer idx = do-  MVar.withMVar (next globalSymbolTable') $ \_next -> do-    IORef.modifyIORef' (mappings globalSymbolTable') $ \SymbolTableMappings {symbolsToText, textToSymbols} ->-      case HashMap.lookup idx symbolsToText of-        Nothing -> error ("Duplicate finalizer called for " <> show idx <> "This should never happen") -- SymbolTableMappings {symbolsToText, textToSymbols}-        Just text ->-          SymbolTableMappings-            { symbolsToText = HashMap.delete idx symbolsToText,-              textToSymbols = Map.delete text textToSymbols-            }-{-# NOINLINE finalizer #-}+-- | Hash an unlifted `Symbol#`, returning an unlifted `Int#`+--+-- Takes O(1) and results in zero collissions, as `StableName`s are used.+hashSymbol## :: Symbol# -> Int#+{-# INLINE hashSymbol## #-}+hashSymbol## (Symbol# ba#) = Accursed.byteArrayStableNameHash## ba#++-- | Compare two unlifted symbols+--+-- The symbols are compared lexicographically using their UTF-8 representation,+-- so this takes linear time.+compareSymbol# :: Symbol# -> Symbol# -> Ordering+{-# INLINE compareSymbol# #-}+compareSymbol# (Symbol# a) (Symbol# b) = Accursed.utf8CompareByteArray# a b++textualToBA# :: (Textual str) => str -> ByteArray#+{-# INLINE textualToBA# #-}+textualToBA# !str =+  let !(SBS ba#) = Text.Short.toShortByteString (Textual.toShortText str)+   in ba#++textualFromBA# :: (Textual str) => ByteArray# -> str+{-# INLINE textualFromBA# #-}+textualFromBA# ba# = Textual.fromShortText (Text.Short.Unsafe.fromShortByteStringUnsafe (SBS ba#))

@@ -1,14 +1,77 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}-module Symbolize.Accursed (accursedUnutterablePerformIO) where+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide, prune #-} -import GHC.IO (IO(IO))-import GHC.Base (realWorld#)+module Symbolize.Accursed (accursedUnutterablePerformIO, utf8CompareByteArray#, shortTextFromBA, byteArrayStableNameHash##) where +import Data.Array.Byte (ByteArray (ByteArray))+import Data.ByteString.Short (ShortByteString (SBS))+import Data.Text.Short (ShortText)+import Data.Text.Short.Unsafe qualified as Text.Short.Unsafe+import GHC.Exts (ByteArray#, Int#, andI#, gtWord#, indexWord8Array#, isTrue#, ltWord#, makeStableName#, realWorld#, sizeofByteArray#, stableNameToInt#, word8ToWord#, (+#), (>=#))+import GHC.IO (IO (IO))+ -- This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but -- it is in fact a malevolent agent of chaos. -- -- Full warning: https://hackage.haskell.org/package/bytestring-0.12.0.2/docs/Data-ByteString-Internal.html#v:accursedUnutterablePerformIO -- (This definition is also taken from there) accursedUnutterablePerformIO :: IO a -> a-accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r {-# INLINE accursedUnutterablePerformIO #-}+accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r++-- Lifted from `base`'s internal `GHC.Encoding.UTF8` module.+-- Since that module could change in any minor version bump,+-- the code is copied to here.+--+-- This special comparison is necessary since+-- normal comparison of `ByteArray`s is non-lexicographic.+utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering+{-# INLINE utf8CompareByteArray# #-}+utf8CompareByteArray# a1 a2 = go 0# 0#+  where+    -- UTF-8 has the property that sorting by bytes values also sorts by+    -- code-points.+    -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property+    -- doesn't hold and we must explicitly check this case here.+    -- Note that decoding every code point would also work but it would be much+    -- more costly.++    !sz1 = sizeofByteArray# a1+    !sz2 = sizeofByteArray# a2+    go off1 off2+      | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ+      | isTrue# (off1 >=# sz1) = LT+      | isTrue# (off2 >=# sz2) = GT+      | otherwise =+          let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)+              !b2_1 = word8ToWord# (indexWord8Array# a2 off2)+           in case b1_1 of+                0xC0## -> case b2_1 of+                  0xC0## -> go (off1 +# 1#) (off2 +# 1#)+                  _ -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of+                    0x80## -> LT+                    _ -> go (off1 +# 1#) (off2 +# 1#)+                _ -> case b2_1 of+                  0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of+                    0x80## -> GT+                    _ -> go (off1 +# 1#) (off2 +# 1#)+                  _+                    | isTrue# (b1_1 `gtWord#` b2_1) -> GT+                    | isTrue# (b1_1 `ltWord#` b2_1) -> LT+                    | otherwise -> go (off1 +# 1#) (off2 +# 1#)++-- Helper function to go from ByteArray to ShortText.+-- Does *not* check whether it is valid UTF-8!+shortTextFromBA :: ByteArray -> ShortText+{-# INLINE shortTextFromBA #-}+shortTextFromBA (ByteArray ba#) = Text.Short.Unsafe.fromShortByteStringUnsafe (SBS ba#)++-- Calculate the stable name for an unlifted ByteArray#,+-- and immediately calculate its hash+byteArrayStableNameHash## :: ByteArray# -> Int#+{-# INLINE byteArrayStableNameHash## #-}+byteArrayStableNameHash## ba# =+  case makeStableName# ba# realWorld# of+    (# _, sname# #) -> stableNameToInt# sname#

@@ -0,0 +1,278 @@+-- Source code taken from the `memory` library+-- https://hackage.haskell.org/package/memory+--+-- But adapted to work on (not necessarily pinned) `ByteArray`+-- rather than on `Ptr`s.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MagicHash #-}++module Symbolize.SipHash+  ( SipKey (..),+    SipHash (..),+    hash,+    hashWith,+  )+where++import Control.Monad (liftM2, liftM3, liftM4, liftM5)+import Data.Array.Byte (ByteArray (ByteArray))+import Data.Bits (Bits (rotateL, unsafeShiftL, xor, (.|.)))+import Data.Functor.Identity (Identity (runIdentity))+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Typeable (Typeable)+import Data.Word (Word32, Word64, Word8, byteSwap64)+import Foreign (alloca)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable (peek, poke))+import GHC.Exts (indexWord8Array#, indexWord8ArrayAsWord64#, sizeofByteArray#)+import GHC.Int (Int (I#))+import GHC.Word (Word64 (..), Word8 (..))+import System.Random (Uniform)+import System.Random.Stateful (Uniform (uniformM))++-- | SigHash Key+data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+  deriving (Show)++instance Uniform SipKey where+  uniformM g = do+    a <- uniformM g+    b <- uniformM g+    pure (SipKey a b)++-- | Siphash tag value+newtype SipHash = SipHash Word64+  deriving (Show, Eq, Ord, Typeable)++data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64++-- | produce a siphash with a key and a memory pointer + length.+hash :: SipKey -> ByteArray -> SipHash+{-# INLINE hash #-}+hash = hashWith 2 4++-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest.+hashWith ::+  -- | siphash C+  Int ->+  -- | siphash D+  Int ->+  -- | key for the hash+  SipKey ->+  -- | start of byte array+  ByteArray ->+  SipHash+{-# INLINE hashWith #-}+hashWith c d key startPtr = runIdentity $ runHash (initSip key) startPtr 0 totalLen+  where+    !totalLen = sizeofByteArray startPtr+    runHash !st !ba !ptr l+      | l > 7 =+          let v = indexWord8ArrayAsWord64 ba ptr in runHash (process st (fromLE (LE v))) ba (ptr + 8) (l - 8)+      | otherwise = do+          let peekByteOff pointer offset = pure (indexByteArray ba (pointer + offset))+          let !lengthBlock = (fromIntegral totalLen `mod` 256) `unsafeShiftL` 56+          (finish . process st) `fmap` case l of+            0 -> do return lengthBlock+            1 -> do+              v0 <- peekByteOff ptr 0+              return (lengthBlock .|. to64 v0)+            2 -> do+              (v0, v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1)+              return+                ( lengthBlock+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            3 -> do+              (v0, v1, v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)+              return+                ( lengthBlock+                    .|. (to64 v2 `unsafeShiftL` 16)+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            4 -> do+              (v0, v1, v2, v3) <-+                liftM4+                  (,,,)+                  (peekByteOff ptr 0)+                  (peekByteOff ptr 1)+                  (peekByteOff ptr 2)+                  (peekByteOff ptr 3)+              return+                ( lengthBlock+                    .|. (to64 v3 `unsafeShiftL` 24)+                    .|. (to64 v2 `unsafeShiftL` 16)+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            5 -> do+              (v0, v1, v2, v3, v4) <-+                liftM5+                  (,,,,)+                  (peekByteOff ptr 0)+                  (peekByteOff ptr 1)+                  (peekByteOff ptr 2)+                  (peekByteOff ptr 3)+                  (peekByteOff ptr 4)+              return+                ( lengthBlock+                    .|. (to64 v4 `unsafeShiftL` 32)+                    .|. (to64 v3 `unsafeShiftL` 24)+                    .|. (to64 v2 `unsafeShiftL` 16)+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            6 -> do+              v0 <- peekByteOff ptr 0+              v1 <- peekByteOff ptr 1+              v2 <- peekByteOff ptr 2+              v3 <- peekByteOff ptr 3+              v4 <- peekByteOff ptr 4+              v5 <- peekByteOff ptr 5+              return+                ( lengthBlock+                    .|. (to64 v5 `unsafeShiftL` 40)+                    .|. (to64 v4 `unsafeShiftL` 32)+                    .|. (to64 v3 `unsafeShiftL` 24)+                    .|. (to64 v2 `unsafeShiftL` 16)+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            7 -> do+              v0 <- peekByteOff ptr 0+              v1 <- peekByteOff ptr 1+              v2 <- peekByteOff ptr 2+              v3 <- peekByteOff ptr 3+              v4 <- peekByteOff ptr 4+              v5 <- peekByteOff ptr 5+              v6 <- peekByteOff ptr 6+              return+                ( lengthBlock+                    .|. (to64 v6 `unsafeShiftL` 48)+                    .|. (to64 v5 `unsafeShiftL` 40)+                    .|. (to64 v4 `unsafeShiftL` 32)+                    .|. (to64 v3 `unsafeShiftL` 24)+                    .|. (to64 v2 `unsafeShiftL` 16)+                    .|. (to64 v1 `unsafeShiftL` 8)+                    .|. to64 v0+                )+            _ -> error "siphash: internal error: cannot happens"++    {-# INLINE to64 #-}+    to64 :: Word8 -> Word64+    to64 = fromIntegral++    {-# INLINE process #-}+    process istate m = newState+      where+        newState = postInject $! runRoundsCompression $! preInject istate+        preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m)+        postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3++    {-# INLINE finish #-}+    finish istate = getDigest $! runRoundsDigest $! preInject istate+      where+        getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3)+        preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3++    {-# INLINE doRound #-}+    doRound (InternalState v0 v1 v2 v3) =+      let !v0' = v0 + v1+          !v2' = v2 + v3+          !v1' = v1 `rotateL` 13+          !v3' = v3 `rotateL` 16+          !v1'' = v1' `xor` v0'+          !v3'' = v3' `xor` v2'+          !v0'' = v0' `rotateL` 32+          !v2'' = v2' + v1''+          !v0''' = v0'' + v3''+          !v1''' = v1'' `rotateL` 17+          !v3''' = v3'' `rotateL` 21+          !v1'''' = v1''' `xor` v2''+          !v3'''' = v3''' `xor` v0'''+          !v2''' = v2'' `rotateL` 32+       in InternalState v0''' v1'''' v2''' v3''''++    {-# INLINE runRoundsCompression #-}+    runRoundsCompression st+      | c == 2 = doRound $! doRound st+      | otherwise = loopRounds c st++    {-# INLINE runRoundsDigest #-}+    runRoundsDigest st+      | d == 4 = doRound $! doRound $! doRound $! doRound st+      | otherwise = loopRounds d st++    {-# INLINE loopRounds #-}+    loopRounds 1 !v = doRound v+    loopRounds n !v = loopRounds (n - 1) (doRound v)++    {-# INLINE initSip #-}+    initSip (SipKey k0 k1) =+      InternalState+        (k0 `xor` 0x736f6d6570736575)+        (k1 `xor` 0x646f72616e646f6d)+        (k0 `xor` 0x6c7967656e657261)+        (k1 `xor` 0x7465646279746573)++-- | Convert from a little endian value to the cpu endianness+fromLE :: LE Word64 -> Word64+#ifdef ARCH_IS_LITTLE_ENDIAN+fromLE (LE a) = a+#elif ARCH_IS_BIG_ENDIAN+fromLE (LE a) = byteSwap64 a+#else+fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap64 a+#endif+{-# INLINE fromLE #-}++-- | Little Endian value+newtype LE a = LE {unLE :: a}+  deriving (Show, Eq)++-- | represent the CPU endianness+--+-- Big endian system stores bytes with the MSB as the first byte.+-- Little endian system stores bytes with the LSB as the first byte.+--+-- middle endian is purposely avoided.+data Endianness+  = LittleEndian+  | BigEndian+  deriving (Show, Eq)++-- | Return the system endianness+getSystemEndianness :: Endianness+#ifdef ARCH_IS_LITTLE_ENDIAN+getSystemEndianness = LittleEndian+#elif ARCH_IS_BIG_ENDIAN+getSystemEndianness = BigEndian+#else+getSystemEndianness+    | isLittleEndian = LittleEndian+    | isBigEndian    = BigEndian+    | otherwise      = error "cannot determine endianness"+  where+        isLittleEndian = endianCheck == 2+        isBigEndian    = endianCheck == 1+        endianCheck    = unsafeDupablePerformIO $ alloca $ \p -> do+                            poke p (0x01000002 :: Word32)+                            peek (castPtr p :: Ptr Word8)+#endif++indexByteArray :: ByteArray -> Int -> Word8+{-# INLINE indexByteArray #-}+indexByteArray (ByteArray arr#) (I# i#) = W8# (indexWord8Array# arr# i#)++indexWord8ArrayAsWord64 :: ByteArray -> Int -> Word64+{-# INLINE indexWord8ArrayAsWord64 #-}+indexWord8ArrayAsWord64 (ByteArray arr#) (I# i#) = W64# (indexWord8ArrayAsWord64# arr# i#)++-- | Size of the byte array in bytes.+sizeofByteArray :: ByteArray -> Int+{-# INLINE sizeofByteArray #-}+sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#)

@@ -0,0 +1,187 @@+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide, prune #-}++module Symbolize.SymbolTable+  ( insertGlobal,+    lookupGlobal,+    removeGlobal,+    GlobalSymbolTable,+    globalSymbolTable,+    globalSymbolTableSize,+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Array.Byte (ByteArray (ByteArray))+import Data.Foldable qualified as Foldable+import Data.IORef (IORef)+import Data.IORef qualified as IORef+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List qualified+import Data.Maybe (mapMaybe)+import GHC.Exts (ByteArray#, StableName#, Weak#, deRefWeak#, makeStableName#, mkWeak#)+import GHC.IO (IO (IO), unsafePerformIO)+import Symbolize.Accursed qualified+import Symbolize.Accursed qualified as Accursed+import Symbolize.SipHash qualified as SipHash+import System.IO.Unsafe qualified+import System.Random.Stateful qualified as Random (Uniform (uniformM), globalStdGen)+import Prelude hiding (lookup)++-- Inside the WeakSymbol+-- we keep:+-- - A weak pointer to the underlying ByteArray#.+--   This weak pointer will be invalidated (turn into a 'tombstone')+--   when the final instance of this symbol is GC'd+-- - A `StableName` for the same ByteArray#+--   This ensures we have a stable hash even in the presence of the ByteArray#+--   being moved around by the GC.+--   We never read it after construction,+--   but by keeping it around until the WeakSymbol is removed by the finalizer,+--   we ensure that future calls to `makeStableName` return the same hash.+data WeakSymbol where+  WeakSymbol# :: Weak# ByteArray# -> StableName# ByteArray# -> WeakSymbol++newtype SymbolTable = SymbolTable (IntMap [WeakSymbol])++-- | The global Symbol Table, containing a mapping between each symbol's textual representation and its deduplicated pointer.+--+-- You cannot manipulate the table itself directly,+-- but you can use `globalSymbolTable` to get a handle to it and use its `Show` instance for introspection.+--+-- `globalSymbolTableSize` can similarly be used to get the current size of the table.+--+-- Current implementation details (these might change even between PVP-compatible versions):+--+-- - An `IntMap` is used for mapping $(SipHash text) -> weak symbol$.+--   Such an IntMap has O(min(n, 64)) lookup time.+-- - Since SipHash is used as hashing algorithm and the key that is used+--   is randomized on global table initialization,+--   the table is resistent to HashDoS attacks.+data GlobalSymbolTable = GlobalSymbolTable (IORef SymbolTable) SipHash.SipKey++newtype Hash = Hash {hashToInt :: Int}++-- | What exactly this `Show` instance prints might change between PVP-compatible versions+instance Show GlobalSymbolTable where+  -- SAFETY: We're only reading, and do not care about performance here.+  show (GlobalSymbolTable table _) = System.IO.Unsafe.unsafePerformIO $ do+    SymbolTable symtab <- IORef.readIORef table+    let contents = Data.List.sort $ map Accursed.shortTextFromBA $ foldMap aliveWeaks $ IntMap.elems symtab+    pure $ "GlobalSymbolTable { size = " <> show (length contents) <> ", symbols = " <> show contents <> " }"++insertGlobal :: ByteArray# -> IO ByteArray+{-# INLINE insertGlobal #-}+insertGlobal ba# = do+  GlobalSymbolTable gsymtab sipkey <- globalSymbolTable+  let !key = calculateHash sipkey ba#+  let !weak = mkWeakSymbol ba# (removeGlobal key)+  IORef.atomicModifyIORef' gsymtab $ \table ->+    case lookup ba# sipkey table of+      Just ba -> (table, ba)+      Nothing ->+        (insert key weak table, ByteArray ba#)++lookupGlobal :: ByteArray# -> IO (Maybe ByteArray)+{-# INLINE lookupGlobal #-}+lookupGlobal ba# = do+  GlobalSymbolTable gsymtab sipkey <- globalSymbolTable+  table <- IORef.readIORef gsymtab+  pure (lookup ba# sipkey table)++removeGlobal :: Hash -> IO ()+{-# INLINE removeGlobal #-}+removeGlobal !key = do+  GlobalSymbolTable gsymtab _ <- globalSymbolTable+  IORef.atomicModifyIORef' gsymtab $ \table ->+    (remove key table, ())++insert :: Hash -> WeakSymbol -> SymbolTable -> SymbolTable+{-# INLINE insert #-}+insert key weak (SymbolTable table) =+  let table' = IntMap.insertWith (++) (hashToInt key) (pure weak) table+   in SymbolTable table'++lookup :: ByteArray# -> SipHash.SipKey -> SymbolTable -> Maybe ByteArray+{-# INLINE lookup #-}+lookup ba# sipkey (SymbolTable table) = do+  let !key = calculateHash sipkey ba#+  weaks <- IntMap.lookup (hashToInt key) table+  Foldable.find (\other -> other == ByteArray ba#) (aliveWeaks weaks)++remove :: Hash -> SymbolTable -> SymbolTable+{-# INLINE remove #-}+remove (Hash key) (SymbolTable table) =+  let table' = IntMap.update removeTombstones key table+   in SymbolTable table'+  where+    removeTombstones weaks =+      case filter isNoTombstone weaks of+        [] -> Nothing+        leftover -> Just leftover+    isNoTombstone weak =+      case deRefWeakSymbol weak of+        Nothing -> False+        Just _ -> True++-- TODO: Replace with SipHash+calculateHash :: SipHash.SipKey -> ByteArray# -> Hash+{-# INLINE calculateHash #-}+calculateHash sipkey ba# =+  let (SipHash.SipHash word) = SipHash.hash sipkey (ByteArray ba#)+   in Hash (fromIntegral word)++mkWeakSymbol :: ByteArray# -> IO () -> WeakSymbol+{-# INLINE mkWeakSymbol #-}+mkWeakSymbol ba# (IO finalizer#) = +    -- SAFETY: This should even be safe+    -- in the prescence of inlining, CSE and full laziness+    --+    -- because the result is outwardly pure+    -- and the finalizer we use is idempotent+    Symbolize.Accursed.accursedUnutterablePerformIO $+  IO $ \s1 -> case mkWeak# ba# ba# finalizer# s1 of+    (# s2, weak# #) ->+      case makeStableName# ba# s2 of+        (# s3, sname# #) ->+          (# s3, WeakSymbol# weak# sname# #)++deRefWeakSymbol :: WeakSymbol -> Maybe ByteArray+{-# INLINE deRefWeakSymbol #-}+deRefWeakSymbol (WeakSymbol# w _sn) = +    -- SAFETY: This should even be safe+    -- in the prescence of inlining, CSE and full laziness;+    Symbolize.Accursed.accursedUnutterablePerformIO $ IO $ \s ->+  case deRefWeak# w s of+    (# s1, flag, p #) -> case flag of+      0# -> (# s1, Nothing #)+      _ -> (# s1, Just (ByteArray p) #)++aliveWeaks :: [WeakSymbol] -> [ByteArray]+{-# INLINE aliveWeaks #-}+aliveWeaks = mapMaybe $ \weak -> deRefWeakSymbol weak++-- | Get a handle to the `GlobalSymbolTable`+--+-- This can be used for pretty-printing using its `Show` instance+globalSymbolTable :: (MonadIO m) => m GlobalSymbolTable+globalSymbolTable = liftIO $ pure globalSymbolTable'++globalSymbolTable' :: GlobalSymbolTable+-- SAFETY: We need all calls to globalSymbolTable' to use the same thunk, so NOINLINE.+{-# NOINLINE globalSymbolTable' #-}+globalSymbolTable' = unsafePerformIO $ do+  !ref <- IORef.newIORef (SymbolTable mempty)+  !sipkey <- Random.uniformM Random.globalStdGen+  pure (GlobalSymbolTable ref sipkey)++-- | Returns the current size of the global symbol table. Useful for introspection or metrics.+globalSymbolTableSize :: IO Word+globalSymbolTableSize = do+  GlobalSymbolTable gsymtab _ <- globalSymbolTable+  SymbolTable table <- IORef.readIORef gsymtab+  let size = fromIntegral (IntMap.size table)+  pure size

@@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleInstances #-}+ -- NOTE: FlexibleInstances is needed to support `String` instance :-(  module Symbolize.Textual (Textual (..)) where +import Data.Array.Byte (ByteArray (ByteArray)) import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as ShortByteString@@ -11,10 +13,10 @@ import qualified Data.Text.Encoding as Text.Encoding import qualified Data.Text.Encoding.Error as Text.Encoding.Error import qualified Data.Text.Lazy as LText-import Data.Text.Short (ShortText)-import qualified Data.Text.Short as ShortText import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Short (ShortText)+import qualified Data.Text.Short as ShortText  -- | Implemented by any String-like types. -- The symbol table uses `ShortText` for its internal storage, so any type which can be converted to it@@ -58,7 +60,7 @@   fromShortText = LText.fromStrict . ShortText.toText   {-# INLINE fromShortText #-} --- | +-- | -- - toShortText: O(n). Evaluates the entire builder. -- - fromShortText: O(1) instance Textual Builder where@@ -93,3 +95,12 @@    fromShortText = ShortText.toByteString   {-# INLINE fromShortText #-}++-- |+-- - toShortText: O(n). Turns invalid UTF-8 into the Unicode replacement character.+-- - fromShortText: O(0) no-op+instance Textual ByteArray where+  toShortText (ByteArray ba) = toShortText (ShortByteString.SBS ba)+  fromShortText short =+    let !(ShortByteString.SBS ba) = fromShortText short+     in ByteArray ba

@@ -1,26 +1,30 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           symbolize-version:        0.1.0.3+version:        1.0.0.0 synopsis:       Efficient global Symbol table, with Garbage Collection. description:    Symbols, also known as Atoms or Interned Strings, are a common technique                 to reduce memory usage and improve performance when using many small strings.                 .-                By storing a single copy of each encountered string in a global table and giving out indexes to that table,+                By storing a single copy of each encountered string in a global table and giving out pointers to the stored keys,                 it is possible to compare strings for equality in constant time, instead of linear (in string size) time.+                Furthermore, by using `StableName`, hashing of Symbols also takes constant-time, so `Symbol`s make great hashmap keys!.                 .-                The main advantages of Symbolize over existing symbol table implementations are:+                The main advantages of Symbolize over other symbol table implementations are:                 .                 - Garbage collection: Symbols which are no longer used are automatically cleaned up.-                - `Symbol`s have a memory footprint of exactly 1 `Word` and are nicely unpacked by GHC.-                - Support for any `Textual` type, including `String`, (strict and lazy) `Data.Text`, (strict and lazy) `Data.ByteString` etc.-                - Thread-safe.-                - Calls to `lookup` and `unintern` are free of atomic memory barriers (and never have to wait on a concurrent thread running `intern`)-                - Support for a maximum of 2^64 symbols at the same time (you'll probably run out of memory before that point).+                - Support for any `Textual` type, including `String`, (strict and lazy) `Data.Text`, (strict and lazy) `Data.ByteString`, `ShortText`, `ShortByteString`, etc.+                - Great memory usage:+                   - `Symbol`s are simply a (lifted) wrapper around a `ByteArray#`, which is nicely unpacked by GHC.+                   - The symbol table is an `IntMap` that contains weak pointers to these same `ByteArray#`s and their associated `StableName#`s+                - Great performance:+                  - `unintern` is a simple pointer-dereference+                  - calls to `lookup` are free of atomic memory barriers (and never have to wait on a concurrent thread running `intern`)+                - Thread-safe                 .                 Please see the full README below or on GitHub at <https://github.com/Qqwy/haskell-symbolize#readme> category:       Data, Data Structures@@ -28,7 +32,7 @@ bug-reports:    https://github.com/Qqwy/haskell-symbolize/issues author:         Qqwy / Marten maintainer:     qqwy@gmx.com-copyright:      2023 Marten Wijnja+copyright:      2023-2025 Marten Wijnja license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple@@ -43,9 +47,11 @@ library   exposed-modules:       Symbolize-  other-modules:+      Symbolize.SymbolTable       Symbolize.Textual+  other-modules:       Symbolize.Accursed+      Symbolize.SipHash   hs-source-dirs:       src   default-extensions:@@ -57,14 +63,13 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints   build-depends:       base >=4.7 && <5-    , bytestring >=0.11.0 && <0.12+    , bytestring >=0.11.0 && <0.13     , containers >=0.6.0 && <0.7-    , deepseq >=1.4.0 && <1.5+    , deepseq >=1.4.0 && <1.6     , hashable >=1.4.0 && <1.5+    , random >=1.2 && <2     , text >=2.0 && <2.2-    , text-display >=0.0.5 && <0.1     , text-short >=0.1.0 && <0.2-    , unordered-containers >=0.2.0 && <0.3   default-language: Haskell2010  test-suite symbolize-doctest@@ -85,16 +90,15 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.7 && <5-    , bytestring >=0.11.0 && <0.12+    , bytestring >=0.11.0 && <0.13     , containers >=0.6.0 && <0.7-    , deepseq >=1.4.0 && <1.5+    , deepseq >=1.4.0 && <1.6     , doctest-parallel     , hashable >=1.4.0 && <1.5+    , random >=1.2 && <2     , symbolize     , text >=2.0 && <2.2-    , text-display >=0.0.5 && <0.1     , text-short >=0.1.0 && <0.2-    , unordered-containers >=0.2.0 && <0.3   default-language: Haskell2010  test-suite symbolize-test@@ -119,18 +123,17 @@   build-depends:       async     , base >=4.7 && <5-    , bytestring >=0.11.0 && <0.12+    , bytestring >=0.11.0 && <0.13     , containers >=0.6.0 && <0.7-    , deepseq >=1.4.0 && <1.5+    , deepseq >=1.4.0 && <1.6     , hashable >=1.4.0 && <1.5     , hedgehog+    , random >=1.2 && <2     , symbolize     , tasty     , tasty-golden     , tasty-hedgehog     , tasty-hunit     , text >=2.0 && <2.2-    , text-display >=0.0.5 && <0.1     , text-short >=0.1.0 && <0.2-    , unordered-containers >=0.2.0 && <0.3   default-language: Haskell2010