diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/src/Symbolize.hs b/src/Symbolize.hs --- a/src/Symbolize.hs +++ b/src/Symbolize.hs @@ -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#)) diff --git a/src/Symbolize/Accursed.hs b/src/Symbolize/Accursed.hs --- a/src/Symbolize/Accursed.hs +++ b/src/Symbolize/Accursed.hs @@ -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# diff --git a/src/Symbolize/SipHash.hs b/src/Symbolize/SipHash.hs new file mode 100644 --- /dev/null +++ b/src/Symbolize/SipHash.hs @@ -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#) diff --git a/src/Symbolize/SymbolTable.hs b/src/Symbolize/SymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/Symbolize/SymbolTable.hs @@ -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 diff --git a/src/Symbolize/Textual.hs b/src/Symbolize/Textual.hs --- a/src/Symbolize/Textual.hs +++ b/src/Symbolize/Textual.hs @@ -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 diff --git a/symbolize.cabal b/symbolize.cabal --- a/symbolize.cabal +++ b/symbolize.cabal @@ -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 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