diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `symbolize` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,116 @@ +# Symbolize +[![Hackage](http://img.shields.io/hackage/v/symbolize.svg)](https://hackage.haskell.org/package/symbolize) + +Haskell library implementing 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, +it is possible to compare strings for equality in constant time, instead of linear (in string size) time. + +The main advantages of Symbolize over existing 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). + +## Basic usage + +This module is intended to be imported qualified, e.g. + + +```haskell +import Symbolize (Symbol) +import qualified Symbolize +``` + +To intern a string, use `intern`: + +```haskell +>>> hello = Symbolize.intern "hello" +>>> world = Symbolize.intern "world" +>>> (hello, world) +(Symbolize.intern "hello",Symbolize.intern "world") +``` + +Interning supports any `Textual` type, so you can also use `Data.Text` or `Data.ByteString` etc.: + +```haskell +>>> import Data.Text (Text) +>>> niceCheeses = fmap Symbolize.intern (["Roquefort", "Camembert", "Brie"] :: [Text]) +>>> 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: + +```haskell +>>> hello2 = ("hello" :: Symbol) +>>> hello2 +Symbolize.intern "hello" +``` + +Comparisons between symbols run in O(1) time: + +```haskell +>>> hello == hello2 +True +>>> hello == world +False +``` + +To get back the textual value of a symbol, use `unintern`: + +```haskell +>>> Symbolize.unintern hello +"hello" +``` + +If you only want to check whether a string is already interned, use `lookup`: + +```haskell +>>> Symbolize.lookup "hello" +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: + +```haskell +>>> import qualified Data.Hashable as Hashable +>>> Hashable.hash hello +0 +>>> fmap Hashable.hash niceCheeses +[2,3,4] +``` + +For introspection, you can look at how many symbols currently exist: + +```haskell +>>> Symbolize.globalSymbolTableSize +5 +>>> [unintern (intern (show x)) | x <- [1..5]] +["1","2","3","4","5"] +>>> Symbolize.globalSymbolTableSize +10 +``` + +Unused symbols will be garbage-collected, so you don't have to worry about memory leaks: + +```haskell +>>> System.Mem.performGC +>>> Symbolize.globalSymbolTableSize +5 +``` + +For deeper introspection, you can look at the Show instance of the global symbol table: +/(Note that the exact format is subject to change.)/ + +```haskell +>>> Symbolize.globalSymbolTable +GlobalSymbolTable { count = 5, next = 10, contents = [(0,"hello"),(1,"world"),(2,"Roquefort"),(3,"Camembert"),(4,"Brie")] } +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Symbolize.hs b/src/Symbolize.hs new file mode 100644 --- /dev/null +++ b/src/Symbolize.hs @@ -0,0 +1,379 @@ +-- | 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, +-- it is possible to compare strings for equality in constant time, instead of linear (in string size) time. +-- +-- The main advantages of Symbolize over existing 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). +-- +-- == Basic usage +-- +-- This module is intended to be imported qualified, e.g. +-- +-- > import Symbolize (Symbol) +-- > import qualified Symbolize +-- +-- To intern a string, use `intern`: +-- +-- >>> hello = Symbolize.intern "hello" +-- >>> world = Symbolize.intern "world" +-- >>> (hello, world) +-- (Symbolize.intern "hello",Symbolize.intern "world") +-- +-- Interning supports any `Textual` type, so you can also use `Data.Text` or `Data.ByteString` etc.: +-- +-- >>> import Data.Text (Text) +-- >>> niceCheeses = fmap Symbolize.intern (["Roquefort", "Camembert", "Brie"] :: [Text]) +-- >>> 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: +-- +-- >>> hello2 = ("hello" :: Symbol) +-- >>> hello2 +-- Symbolize.intern "hello" +-- >>> Symbolize.intern ("world" :: Text) +-- Symbolize.intern "world" +-- +-- Comparisons between symbols run in O(1) time: +-- +-- >>> hello == hello2 +-- True +-- >>> hello == world +-- False +-- +-- To get back the textual value of a symbol, use `unintern`: +-- +-- >>> Symbolize.unintern hello +-- "hello" +-- +-- If you want to check whether a string is currently interned, use `lookup`: +-- +-- >>> Symbolize.lookup "hello" +-- 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: +-- +-- >>> Data.Hashable.hash hello +-- 0 +-- >>> fmap Data.Hashable.hash niceCheeses +-- [2,3,4] +-- +-- For introspection, you can look at how many symbols currently exist: +-- +-- >>> Symbolize.globalSymbolTableSize +-- 5 +-- >>> [unintern (intern (show x)) | x <- [1..5]] +-- ["1","2","3","4","5"] +-- >>> Symbolize.globalSymbolTableSize +-- 10 +-- +-- Unused symbols will be garbage-collected, so you don't have to worry about memory leaks: +-- +-- >>> System.Mem.performGC +-- >>> Symbolize.globalSymbolTableSize +-- 5 +-- +-- For deeper introspection, you can look at the Show instance of the global symbol table: +-- /(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")] } +module Symbolize + ( -- * Symbol + Symbol, + intern, + unintern, + lookup, + Textual (..), + + -- * Introspection & Metrics + GlobalSymbolTable, + globalSymbolTable, + globalSymbolTableSize, + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar (MVar) +import qualified Control.Concurrent.MVar as MVar +import Control.DeepSeq (NFData (..)) +import Data.Function ((&)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (Hashable (..)) +import Data.IORef (IORef) +import qualified Data.IORef as IORef +import Data.String (IsString (..)) +import Data.Text.Display (Display (..)) +import Data.Text.Short (ShortText) +import GHC.Read (Read (..)) +import qualified Symbolize.Accursed +import Symbolize.Textual (Textual (..)) +import qualified System.IO.Unsafe +import System.Mem.Weak (Weak) +import qualified System.Mem.Weak as Weak +import Text.Read (Lexeme (Ident), lexP, parens, prec, readListPrecDefault) +import qualified Text.Read +import Prelude hiding (lookup) + +-- | 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. +-- +-- 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!) +-- +-- The 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. +-- +-- 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. +-- +-- 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 + +instance Show Symbol where + showsPrec p symbol = + let !str = unintern @String symbol + in showParen (p > 10) $ + showString "Symbolize.intern " . shows str + +-- | To be a good citizen w.r.t both `Show` and `IsString`, reading is supported two ways: +-- +-- >>> read @Symbol "Symbolize.intern \"Haskell\"" +-- Symbolize.intern "Haskell" +-- >>> read @Symbol "\"Curry\"" +-- Symbolize.intern "Curry" +instance Read Symbol where + readListPrec = readListPrecDefault + readPrec = parens $ prec 10 $ full <|> onlyString + where + onlyString = do + str <- readPrec @String + return $ Symbolize.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 (==) #-} + +-- | Symbol contains only a strict `Word`, so it is already fully evaluated. +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 #-} + +-- | +-- 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. +-- +-- `hashWithSalt` takes O(1) time; just as long as hashWithSalt-ing any other `Word`. +instance Hashable Symbol where + hash (Symbol idx) = hash idx + hashWithSalt salt (Symbol idx) = hashWithSalt salt idx + {-# INLINE hash #-} + {-# INLINE hashWithSalt #-} + +-- | The global Symbol Table, containing a bidirectional mapping between each symbol's textual representation and its Word index. +-- +-- 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. +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) + <> " }" + +data SymbolTableMappings = SymbolTableMappings + { textToSymbols :: !(HashMap ShortText (Weak Symbol)), + symbolsToText :: !(HashMap Word ShortText) + } + +-- | 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 #-} + +-- | Looks up a symbol in the global symbol table. +-- +-- Returns `Nothing` if no such symbol currently exists. +-- +-- Takes O(log16 n) 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 & HashMap.lookup text' + case maybeWeak of + Nothing -> pure Nothing + Just weak -> do + Weak.deRefWeak weak +{-# NOINLINE lookup #-} + +-- | Intern a string-like 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(log16 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). +-- +-- 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 = HashMap.insert text' weakSymbol textToSymbols + } + IORef.atomicWriteIORef (mappings globalSymbolTable') mappings2 + + let !nextFree = idx + 1 + pure (nextFree, symbol) +{-# INLINE intern #-} + +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 + +-- | 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 + +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 HashMap.empty HashMap.empty) + return (GlobalSymbolTable nextRef mappingsRef) +{-# NOINLINE globalSymbolTable' #-} + +-- | 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 + +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 = HashMap.delete text textToSymbols + } +{-# NOINLINE finalizer #-} diff --git a/src/Symbolize/Accursed.hs b/src/Symbolize/Accursed.hs new file mode 100644 --- /dev/null +++ b/src/Symbolize/Accursed.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Symbolize.Accursed (accursedUnutterablePerformIO) where + +import GHC.IO (IO(IO)) +import GHC.Base (realWorld#) + +-- 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 #-} diff --git a/src/Symbolize/Textual.hs b/src/Symbolize/Textual.hs new file mode 100644 --- /dev/null +++ b/src/Symbolize/Textual.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleInstances #-} +-- NOTE: FlexibleInstances is needed to support `String` instance :-( + +module Symbolize.Textual (Textual (..)) where + +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ShortByteString +import Data.Function ((&)) +import Data.Text (Text) +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 + +-- | Implemented by any String-like types. +-- The symbol table uses `ShortText` for its internal storage, so any type which can be converted to it +-- can be turned to/from a `Symbolize.Symbol`. +-- +-- Instance should handle potential invalid UTF-8 by using the Unicode replacement character, +-- c.f. `Data.Text.Encoding.Error.lenientDecode`. +class Textual a where + toShortText :: a -> ShortText + fromShortText :: ShortText -> a + +-- | +-- - O(0) conversion (a no-op) +instance Textual ShortText where + toShortText = id + {-# INLINE toShortText #-} + fromShortText = id + {-# INLINE fromShortText #-} + +-- | +-- - O(1) conversion +instance Textual Text where + toShortText = ShortText.fromText + {-# INLINE toShortText #-} + fromShortText = ShortText.toText + {-# INLINE fromShortText #-} + +-- | +-- - O(n) conversion +instance Textual String where + toShortText = ShortText.fromString + {-# INLINE toShortText #-} + fromShortText = ShortText.toString + {-# INLINE fromShortText #-} + +-- | +-- - O(1) conversion +instance Textual LText.Text where + toShortText = ShortText.fromText . LText.toStrict + {-# INLINE toShortText #-} + fromShortText = LText.fromStrict . ShortText.toText + {-# INLINE fromShortText #-} + +-- | +-- - toShortText: O(n). Evaluates the entire builder. +-- - fromShortText: O(1) +instance Textual Builder where + toShortText = ShortText.fromText . LText.toStrict . Builder.toLazyText + {-# INLINE toShortText #-} + fromShortText = Builder.fromText . ShortText.toText + {-# INLINE fromShortText #-} + +-- | +-- - toShortText: O(n). Turns invalid UTF-8 into the Unicode replacement character. +-- - fromShortText: O(0) no-op +instance Textual ShortByteString where + toShortText byteString = + byteString + & ShortByteString.fromShort + & Text.Encoding.decodeUtf8With Text.Encoding.Error.lenientDecode + & ShortText.fromText + {-# INLINE toShortText #-} + + fromShortText = ShortText.toShortByteString + {-# INLINE fromShortText #-} + +-- | +-- - toShortText: O(n). Turns invalid UTF-8 into the Unicode replacement character. +-- - fromShortText: O(n). +instance Textual ByteString where + toShortText byteString = + byteString + & Text.Encoding.decodeUtf8With Text.Encoding.Error.lenientDecode + & ShortText.fromText + {-# INLINE toShortText #-} + + fromShortText = ShortText.toByteString + {-# INLINE fromShortText #-} diff --git a/symbolize.cabal b/symbolize.cabal new file mode 100644 --- /dev/null +++ b/symbolize.cabal @@ -0,0 +1,122 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: symbolize +version: 0.1.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, it is possible to compare strings for equality in constant time, instead of linear (in string size) time. + The main advantages of Symbolize over existing 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). + Please see the full README on GitHub at +category: Data, Data Structures +homepage: https://github.com/Qqwy/haskell-symbolize#readme +bug-reports: https://github.com/Qqwy/haskell-symbolize/issues +author: Qqwy / Marten +maintainer: qqwy@gmx.com +copyright: 2023 Marten Wijnja +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/Qqwy/haskell-symbolize + +library + exposed-modules: + Symbolize + other-modules: + Symbolize.Textual + Symbolize.Accursed + hs-source-dirs: + src + default-extensions: + BangPatterns + OverloadedStrings + DeriveAnyClass + TypeApplications + NamedFieldPuns + 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 + , deepseq >=1.4.0 && <1.5 + , hashable >=1.4.0 && <1.5 + , 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 + type: exitcode-stdio-1.0 + main-is: DocTest.hs + other-modules: + Paths_symbolize + autogen-modules: + Paths_symbolize + hs-source-dirs: + test/doctest + default-extensions: + BangPatterns + OverloadedStrings + DeriveAnyClass + TypeApplications + NamedFieldPuns + 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 + , deepseq >=1.4.0 && <1.5 + , doctest-parallel + , hashable >=1.4.0 && <1.5 + , 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 + type: exitcode-stdio-1.0 + main-is: Suite.hs + other-modules: + SymbolizeTest + Paths_symbolize + autogen-modules: + Paths_symbolize + hs-source-dirs: + test/suite + default-extensions: + BangPatterns + OverloadedStrings + DeriveAnyClass + TypeApplications + NamedFieldPuns + 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-tool-depends: + tasty-discover:tasty-discover + build-depends: + async + , base >=4.7 && <5 + , bytestring >=0.11.0 && <0.12 + , deepseq >=1.4.0 && <1.5 + , hashable >=1.4.0 && <1.5 + , hedgehog + , 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 diff --git a/test/doctest/DocTest.hs b/test/doctest/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/doctest/DocTest.hs @@ -0,0 +1,5 @@ +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "symbolize" =<< getArgs diff --git a/test/suite/Suite.hs b/test/suite/Suite.hs new file mode 100644 --- /dev/null +++ b/test/suite/Suite.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} +-- | Tasty test driver module. Auto-discovers any tests +-- in this directory and subdirectories and runs them. +-- +-- c.f. https://hackage.haskell.org/package/tasty-discover diff --git a/test/suite/SymbolizeTest.hs b/test/suite/SymbolizeTest.hs new file mode 100644 --- /dev/null +++ b/test/suite/SymbolizeTest.hs @@ -0,0 +1,46 @@ +module SymbolizeTest where + +-- import qualified System.Mem + +import qualified Control.Concurrent.Async +import Control.Monad.IO.Class (liftIO) +import qualified Data.Hashable +import Data.Text (Text) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Symbolize +import qualified System.Mem +import Test.Tasty.HUnit + +unit_simpleInternUninternTest :: IO () +unit_simpleInternUninternTest = do + System.Mem.performGC + + let str = "hello" :: Text + let !symbol = Symbolize.intern str + + size <- Symbolize.globalSymbolTableSize + size @?= 1 + + let str2 = Symbolize.unintern symbol + str2 @?= str + +hprop_symbolTableIsIdempotent :: Property +hprop_symbolTableIsIdempotent = withTests 1000 $ property $ do + texts <- forAll $ Gen.list (Range.linear 0 200) (Gen.text (Range.linear 0 20) Gen.unicode) + let !symbols = fmap Symbolize.intern texts + annotateShow (fmap Data.Hashable.hash symbols) + let !texts2 = fmap Symbolize.unintern symbols + + texts2 === texts + +hprop_concurrentAccessDoesNotCorruptTable :: Property +hprop_concurrentAccessDoesNotCorruptTable = withTests 500 $ property $ do + let numCores = 8 + texts <- forAll $ Gen.list (Range.linear 0 200) (Gen.text (Range.linear 0 20) Gen.unicode) + results <- liftIO $ Control.Concurrent.Async.forConcurrently [(1 :: Integer) .. numCores] $ \_ -> do + let !texts2 = fmap (\val -> Symbolize.unintern $! Symbolize.intern $! val) texts + pure texts2 + + mapM_ (=== texts) results