simple-atom 0.1.0.1 → 0.2
raw patch · 3 files changed
+346/−271 lines, 3 filesdep +deepseqdep +murmur-hashdep ~basedep ~containers
Dependencies added: deepseq, murmur-hash
Dependency ranges changed: base, containers
Files
- Data/Atom/UF.hs +303/−251
- LICENSE +26/−17
- simple-atom.cabal +17/−3
Data/Atom/UF.hs view
@@ -1,281 +1,199 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, CPP #-} {-# OPTIONS_GHC -funbox-strict-fields #-}--- | --- Module : Data.Atom.UF--- Copyright : (c) Thomas Schilling 2010--- License : BSD-style------ Maintainer : nominolo@gmail.com--- Stability : experimental--- Portability : portable------ Symbols without a central symbol table.------ Symbols provide the following efficient operations:------ - /O(1)/ equality comparison (in practise)--- - /O(1)/ ordering comparison (in practise)--- - /O(n)/ creation------ This can be implemented by using a global variable mapping strings--- to symbols and a counter assigning ids to symbols. However, this--- has two problems:------ 1. It has a space leak. No symbols can ever be removed from this--- table. For example, if we add the symbol @\"foo\"@ the first--- time it might get assigned id 1, if we then delete it and--- insert it again it might get assigned id 42. However, there--- may still be symbols in memory which got assigned id 1.--- Instead, symbols should be garbage collected like other data.--- Using weak pointers has bad effects on performance due to--- garbage collector overhead.------ 2. It is not reliable to compare symbols created using different--- symbol tables. They would most likely get assigned different--- ids.------ This implementation of symbols allows *optional* use of a symbol--- table. If a symbol table is used, this implementation will tend to--- use less memory and its operations will be a little bit faster at--- the beginning. For longer runs, it won't make a big difference--- though, since the representation is self-optimising.------ Inspired by Richard O'Keefe's message to Erlang's eeps mailing list--- <http://www.erlang.org/cgi-bin/ezmlm-cgi/5/057>, which in turn was--- inspired by the Logix implementation of Flat Concurrent Prolog.--------- * Implementation------ Each symbol is represented a pointer to the symbol info, which--- consists of:------ * a 'String'--- * a 'Hash'--- * a null-able parent pointer to an equivalent symbol info------ Creating the same symbol twice will at first be represented as two--- different entities.------ @--- .----+-------+-----.--- A -----> | 42 | "foo" | nil |--- '----+-------+-----'--- B --.--- '--> .----+-------+-----.--- C -----> | 42 | "foo" | nil |--- '----+-------+-----'--- @------ (Note that @A@, @B@ and @C@ are @IORefs@.)------ When comparing @A@ and @B@ we use the following properties:------ 1. If @A@ and @B@ are identical then they must be equal.--- --- 2. If they point to the same object, they must equal.--- --- 3. If they have different hashes, they are different.------ Unless there is a hash collision, we can decide equality and--- ordering for all symbols that have been built with the same hash--- table.------ If the two objects have no parent, have the same hash, and the same--- string, we now make one the first the parent of the other and--- update the pointer of @B@ accordingly. If there are no references--- to the second object left it can now be garbage collected.------ If an object already has a parent pointer we follow each object's--- parents to the roots and compare the roots. This process might--- again result in updates to @A@ or @B@ and various parent pointers.------ In the example above, after @A == B@ we have:------ @--- .----+-------+-----.--- A -----> | 42 | "foo" | nil |--- .--> '----+-------+-----'--- B --' ^--- .----+-------+--|--.--- C -----> | 42 | "foo" | * |--- '----+-------+-----'--- @------ After @C == A@ or @C == B@ we have.------ @--- A -----> .----+-------+-----.--- .--> | 42 | "foo" | nil |--- B --'.-> '----+-------+-----'--- | ^--- | .----+-------+--|--.--- C ---' | 42 | "foo" | * |--- '----+-------+-----'--- @------ The second object will now be garbage collected.------ In fact, after the first @A == B@, the remaining updates could use--- some help from the garbage collector. This could be done by--- somehow forcibly (and unsafely) replacing the second object by an--- update frame and then rely on the GC's indirection shortening--- feature. This is /very/ unsafe, since some code may rely \"know\"--- that the object is already evaluated. E.g., C's pointer could be--- tagged (c.f. \"Faster Laziness Using Dynamic Pointer Tagging\").--- It /might/ work if we can match the physical layout of both--- structures, but it's equally likely that hell freezes over, so I'll--- leave that as an exercise for more braver hackers.------ * TODO------ - generalise to arbitrary hashable objects. need not be--- restricted to 'String'.------ - make thread-safe. (we only need a lock for the uncommon cases)------ - make sure the pointer update code is correct and has no bad--- cases------ - implement IntMap variant\/wrapper that respects that two--- different objects may have the same key (however unlikely).--- -module Data.Atom.UF - ( Symbol, intern, internInto, SymTab(..) )+{-| +Module : Data.Atom.UF+Copyright : (c) Thomas Schilling 2010+License : BSD-style++Maintainer : nominolo@gmail.com+Stability : experimental+Portability : portable++Symbols without a central symbol table.++Symbols provide the following efficient operations:++ - /O(1)/ equality comparison (in practise)++ - /O(1)/ ordering comparison (in practise)++ - /O(n)/ creation where /N/ is the size of the symbol descriptor.++Many implementations often have the additional property that each+symbol descriptor only exists once in memory. This implementation+slightly relaxes this property:++ - A symbol descriptor is guaranteed to exists only once in memory+ if it has been created using the same symbol table.+ Furthermore, if two symbols created from different symbol tables+ are compared and their descriptors turn out to be equal, the+ symbols will share the descriptor after the comparison.++This allows the following additional properties not present in+conventional implementations:++ - No space leak. The symbol table can be discarded at any time.++ - Symbols created using different symbol tables can be compared+ reliably.++ - No global lock. (TODO: Well we might need one in the case of+ hash-collisions, but a lock-free implementation might be+ possible.)++Inspired by Richard O'Keefe's message to Erlang's eeps mailing list+<http://www.erlang.org/cgi-bin/ezmlm-cgi/5/057>, which in turn was+inspired by the Logix implementation of Flat Concurrent Prolog.++-}+module Data.Atom.UF (+ -- * Symbols+ --+ Symbol, intern, internInto, SymTab(..), symbolHash+ -- * Implementation+ --+ -- $impl+ --+) where -import Data.Word ( Word32 )-import Data.Char ( ord )-import Data.Bits ( xor )+import Data.Word ( Word64 ) import Data.IORef import System.IO.Unsafe-import Control.Monad -- ( unless )+import Control.Monad ( unless )+import Control.DeepSeq++#ifndef NDEBUG+-- For testing:+import Control.Monad ( liftM2 ) import System.Mem.Weak import System.Mem-import Data.Maybe+import Data.Digest.Murmur64+import Data.Maybe ( isJust )+#endif -- ------------------------------------------------------------------- -- Public API: -- | A symbol.-newtype Symbol = Symbol (IORef SymbolInfo)-instance Eq Symbol where x == y = cmpSymbol x y == EQ-instance Ord Symbol where compare = cmpSymbol-instance Show Symbol where show = showSym+--+-- Note that the ordering on @a@ is /not/ preserved on @Symbol a@.+-- Symbols are ordered by their hashes, and only if the hashes are+-- equal will the ordering on @a@ be used. We have:+--+-- @+-- x == y ==> intern x == intern y+--+-- let sx = intern x+-- sy = intern y+-- in+-- (sx < sy) == ((symbolHash sy < symbolHash sx) ||+-- symbolHash sy == symbolHash sx && x < y)+-- @+data Symbol a =+ Symbol {-# UNPACK #-} !Word64 -- hash+ {-# UNPACK #-} !(IORef (SymbolInfo a)) +-- | Returns the hash of the symbol.+symbolHash :: Symbol a -> Word64+symbolHash (Symbol h _) = h++instance Ord a => Eq (Symbol a) where x == y = cmpSymbol x y == EQ+instance Ord a => Ord (Symbol a) where compare = cmpSymbol+instance Show a => Show (Symbol a) where+ show = show . symInfo+ -- | Create a new local symbol. For best performance use -- 'internInto' together with a symbol table / map.-intern :: String -> Symbol+intern :: (a -> Word64) -> a -> Symbol a class SymTab s where- lookupSymbol :: s -> String -> Maybe Symbol- insertSymbol :: String -> Symbol -> s -> s+ lookupSymbol :: s a -> a -> Maybe (Symbol a)+ insertSymbol :: a -> (Symbol a) -> s a -> s a -- | Insert a symbol into an existing table.-internInto :: SymTab s => s -> String -> (s, Symbol)+internInto :: (SymTab s) => (a -> Word64) -> s a -> a -> (s a, Symbol a) -- ------------------------------------------------------------------- -- Internals -data SymbolInfo =- SymInfo {-# UNPACK #-} !Word32 -- hash- {-# UNPACK #-} !(IORef Link) -- parent [really unpack]?- String--type Link = Maybe SymbolInfo+newtype SymbolInfo a = SymInfo (IORef (Link a)) +type Link a = Either a (SymbolInfo a) -internInto st str =+internInto hash_fn st str = case lookupSymbol st str of Just sym -> (st, sym)- _ -> let sym = intern str in+ _ -> let sym = intern hash_fn str in (insertSymbol str sym st, sym) -showSym :: Symbol -> String-showSym (Symbol r) = unsafePerformIO $ do- -- dupable/inline is fine, too, since the string never changes- (SymInfo _ _ str) <- readIORef r- return str--intern s = unsafePerformIO $ do- lnk <- newIORef Nothing- r <- newIORef $ SymInfo (hash s) lnk s- return (Symbol r)--mkSymbolInfo :: String -> SymbolInfo-mkSymbolInfo s = unsafePerformIO $ do- lnk <- newIORef Nothing- return $ SymInfo (hash s) lnk s+intern hash_fn s = unsafePerformIO $ do+ info <- newIORef (Left s)+ info' <- newIORef (SymInfo info)+ return (Symbol (hash_fn s) info') -cmpSymbol :: Symbol -> Symbol -> Ordering-cmpSymbol (Symbol r1) (Symbol r2)- | r1 == r2 = EQ- | otherwise = unsafePerformIO $ do- -- We only read. It should be safe to use unsafeInlineIO for- -- the two reads.- sym1@(SymInfo h1 l1 s1) <- readIORef r1- sym2@(SymInfo h2 l2 s2) <- readIORef r2- case h1 `compare` h2 of- -- If the hashes are different they cannot be the same symbol- LT -> return LT- GT -> return GT- EQ- | sameSym sym1 sym2 ->- -- The two references are not the same, but they point to- -- the same object. That's fine, we can't optimise any- -- further.+cmpSymbol :: Ord a => Symbol a -> Symbol a -> Ordering+cmpSymbol (Symbol h1 i1) (Symbol h2 i2)+ | i1 == i2 = EQ+ | otherwise =+ case h1 `compare` h2 of+ EQ -> uncommon_case -- not identical, but same hash+ ans -> ans+ where+ {-# NOINLINE uncommon_case #-}+ uncommon_case = unsafePerformIO $ do+ -- get representative element (performs path shortening)+ (rep1@(SymInfo rr1), s1) <- repr' i1 + (rep2@(SymInfo rr2), s2) <- repr' i2+ if rep1 === rep2 then+ return EQ+ else+ case s1 `compare` s2 of+ EQ -> do -- they should be equal!+ writeIORef rr2 (Right rep1)+ writeIORef i2 rep1 return EQ+ ans -> return ans - -- END OF COMMON CASE- -- - -- If the symbols have been built using the same symbol table- -- we will only reach this case if we have a hash collision or- -- the symbols were built from different symbol tables.- --- -- TODO: Extract into NOINLINE function, wrap unsafePerformIO,- -- and use an MVar-based lock. - | otherwise -> do- -- The hashes are the same. It could be a collision, or the- -- symbol was created using a different symbol table.- --- -- Case 1: The symbols have already be joined, but this- -- Symbol's IORef still points to the old version. We can- -- determine this by following the union/find structure.- rep1 <- repr sym1- rep2 <- repr sym2- let string_cmp = s1 `compare` s2 -- lazy!- if sameSym rep1 rep2 || string_cmp == EQ then do- -- They should in fact be the same symbol. Update the- -- atoms and the symbol infos if necessary.- -- TODO: Use MVar / lock.- unless (sameSym sym1 rep1) $ do- writeIORef r1 rep1- writeIORef l1 (Just rep1) -- path shortening- unless (sameSym sym2 rep1) $ do- writeIORef r2 rep1- writeIORef l2 (Just rep1)- return EQ- else do- -- They are not the same, and they shouldn't- return string_cmp-{-# NOINLINE cmpSymbol #-}- -- We abuse the fact that IORefs give us an identity (i.e., observable -- sharing) and that we need the IORef anyway.-sameSym :: SymbolInfo -> SymbolInfo -> Bool-sameSym (SymInfo _ r1 _) (SymInfo _ r2 _) = r1 == r2+sameSym :: SymbolInfo a -> SymbolInfo a -> Bool+sameSym (SymInfo r1) (SymInfo r2) = r1 == r2 -repr :: SymbolInfo -> IO SymbolInfo-repr sym@(SymInfo _ r _) = do- parent <- readIORef r -- TODO: perform path shortening.- case parent of- Nothing -> return sym- Just sym' -> repr sym'+(===) = sameSym +symInfo :: Symbol a -> a+symInfo (Symbol _ r) = unsafePerformIO $ do+ fmap snd (repr' r)++repr' :: IORef (SymbolInfo a) -> IO (SymbolInfo a, a)+repr' r = do+ info <- readIORef r+ (root_info, str) <- go info+ unless (root_info === info) $+ writeIORef r root_info+ return (root_info, str)+ where+ go si@(SymInfo ir) = do+ i <- readIORef ir+ case i of+ Left str -> return (si, str)+ Right si' -> do+ (root_info, str) <- go si'+ unless (si' === root_info) $+ writeIORef ir (Right root_info) -- is Left possible here?+ return (root_info, str)++----------------------------------------------------------+-- Tests+#ifndef NDEBUG+-- requires import Data.Digest.Murmur32+ test1 = do- let s1@(Symbol r1) = intern "foo"- s2@(Symbol r2) = intern "foo"+ let h = asWord64 . hash64+ s1@(Symbol _ r1) = intern h "foo"+ s2@(Symbol _ r2) = intern h "foo" print $ r1 == r2 -- should be False -- create a weak reference to the second symbol, so we can observe@@ -292,16 +210,150 @@ where mk_weak o = mkWeakPtr o (Just (putStrLn "goodbye")) --- -------------------------------------------------------------------+#endif --- Fowler / Noll / Vo (FNV) hash. Original code expected 'unsigned--- char' input. Don't know whether it behaves worse for unicode--- chars.-hash :: String -> Word32-hash str = go magic_start (map ord str)+{- $doc1++test 1++-}++{- $impl++Each symbol is represented a mutable pointer to the symbol info and a+hash. The symbol info might itself be a pointer to another (equal)+symbol info.++When creating a new symbol (without looking it up in a symbol table),+we compute its hash and create a new symbol info.++> +----+---+ +-------++> A: | 42 | *-----> | "foo" |+> +----+---+ +-------+++We now know the following:++ 1. If two symbols have the same reference, they are equal. (The 'Eq'+ instance on 'IORef's implements observable sharing.)++ 2. If two symbols have a different hash, they are different.++If neither of the above is true we either have a hash collision or the+two objects are equal but were created using different symbol tables.+++Let's consider the latter case:++> +----+---+ +-------++> A: | 42 | *-----> | "foo" |+> +----+---+ +-------++>+> +----+---+ +-------++> B: | 42 | *-----> | "foo" |+> +----+---+ +-------++++We follow the symbol pointers and realise that the symbol descriptors+are equal. We thus decide for one of them to be the canonical symbol+descriptor and update the pointers:+++> +----+---+ +-------++> A: | 42 | *-----> | "foo" |+> +----+---+ .-> +-------++> | ^+> +----+---+ | +---|---++> B: | 42 | *---' | * |+> +----+---+ +-------+++We change the other symbol descriptor to be a pointer to the canonical+descriptor, because there may be other pointers to this symbol+descriptor. Otherwise, the old symbol descriptor becomes garbage. We+now have only one @\"foo\"@ object left.++We can add a third rule for equality:++ - If, following all pointers, two symbol descriptors are the same,+ then the two symbols are equal.++If this is not the case (e.g., in the case of a hash collision) we+call the 'compare' function of the symbol descriptor. A good hash+function is therefore important since in the case of a hash collision+we will always have to call the 'compare' function of the symbol+descriptor.+++** Hash Function++Assuming a good hash function (i.e., the hash is indistinguishable+from a randomly generated number) we can use the birthday paradox to+calculate the probability of a hash collision:++@+collision_prob :: Integer -> Integer -> Double+collision_prob key_bits items =+ 1 - exp (fromIntegral (-items * (items - 1)) / fromIntegral (2 * key_space)) where- magic_start = 2166136261 :: Word32- go :: Word32 -> [Int] -> Word32- go !h [] = h- go !h (c:cs) =- go ((h * 16777619) `xor` fromIntegral c) cs+ key_space = 2 ^ key_bits :: Integer+@++E.g., @collision_prob 32 50000 == 0.2525...@ means that with+32 bit hashes and 50000 symbols, there is a 25 percent chance of a+hash collision.+++** Path Shortening++If symbols from several symbol tables are joined repeatedly, its+symbol infos may develop into long chains. For this reason we update+all pointers while following them.++That is, given we have the following state:++> X+-sym+---+ A+-nfo-+ B+-------++> | 42 | *------->| *------> | "foo" |+> +----+---' +-----' '-------'+>+> Y+-sym+---+ C+-nfo-+ D+-------++> | 42 | *------->| *------> | "foo" |+> +----+---' +-----' '-------'++after @x \`compare\` y@ we have.+++> X+-sym+---+ B+-------+ A+-nfo-+ +> | 42 | *-------> | "foo" |<-------* |+> `----+---' +--> '-------' `-----'+> | ^ ^------++> Y+-sym+---+ | C+-nfo-+| D+---|---++> | 42 | *----' | *---' | * |+> `----+---' `-----' '-------'++These references can be updated concurrently and without a lock since+their information content does not change. That is, the state++> X.-sym+---. A.-nfo-. B.-------.+> | 42 | *------->| *------> | "foo" |+> `----+---' `-----' '-------'++Is semantically equivalent to the state:++> X.-sym+---. A.-nfo-. B.-------.+> | 42 | *----. | *------> | "foo" |+> +----+---+ | +-----+ .-> +-------++> '-----------'++++* TODO++ - verify thread-safety++ - make sure the pointer update code is correct and has no bad+ cases++ - implement IntMap variant\/wrapper that respects that two+ different objects may have the same hash (however unlikely).+++-}
LICENSE view
@@ -1,20 +1,29 @@-Paradox/Equinox -- Copyright (c) 2003-2007, Koen Claessen, Niklas Sorensson+Copyright (c) 2010, Thomas Schilling+All rights reserved. -Permission is hereby granted, free of charge, to any person obtaining a-copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: -The above copyright notice and this permission notice shall be included-in all copies or substantial portions of the Software.+- 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 name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS-OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE 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 UNIVERSITY+COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.
simple-atom.cabal view
@@ -1,5 +1,5 @@ Name: simple-atom-Version: 0.1.0.1+Version: 0.2 License: BSD3 License-File: LICENSE Author: Koen Claessen, Niklas Sorensson@@ -10,9 +10,13 @@ This module provides an abstract datatype for atoms, such that: . * Each atom string is only in memory once+ . * @O(n)@ creation time+ . * @O(1)@ equality-comparison+ . * @O(1)@ (in practice) ord-comparison+ . * @Ord@-comparison results are independent on evaluation order . This module is thread-safe.@@ -22,10 +26,20 @@ Build-Type: Simple Cabal-Version: >= 1.6 +Flag debug+ default: False+ Library Build-Depends:- base >= 3.0 && < 4.7,- containers >= 0.2 && < 0.6+ base >= 3.0 && < 4.4,+ containers >= 0.2 && < 0.5,+ deepseq == 1.1.*++ if (flag(debug))+ Build-Depends: murmur-hash == 0.1.*+ else+ Cpp-Options: -DNDEBUG+ Extensions: CPP exposed-modules: Data.Atom.Simple