diff --git a/Data/Atom/UF.hs b/Data/Atom/UF.hs --- a/Data/Atom/UF.hs +++ b/Data/Atom/UF.hs @@ -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 --- , 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 +, 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). + + +-} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/simple-atom.cabal b/simple-atom.cabal --- a/simple-atom.cabal +++ b/simple-atom.cabal @@ -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