diff --git a/Data/Atom/Simple.hs b/Data/Atom/Simple.hs new file mode 100644 --- /dev/null +++ b/Data/Atom/Simple.hs @@ -0,0 +1,107 @@ +module Data.Atom.Simple + ( Symbol, intern ) +where + +import Data.Char ( ord ) +import qualified Data.Map as M +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef ( newIORef, atomicModifyIORef ) + +-- ------------------------------------------------------------------- +-- Public Interface + +-- | A 'Symbol'. This is essentially a 'String', but with different +-- performance characteristics: +-- +-- * @O(n)@ creation time (using 'insert') +-- +-- * @O(1)@ equality comparison. +-- +-- * @O(1)@ comparison (in practice). The result of 'compare' is +-- independent of evaluation order. +-- +-- It is currently implemented as follows. +-- +-- * Each symbol contains a unique integer, which allows @O(1)@ +-- comparison. +-- +-- * Each symbol contains an infinite chain of hashes, these are used +-- for comparison. In practice, it is very rare that more than the +-- first of those hashes is ever evaluated. The first hash is +-- cached, so that most comparisons will not need any indirections. +-- +-- * The 'String' representation of the symbol. Use 'show' to return +-- it. At any time, there will be only one symbol of a given name +-- in memory. +-- +data Symbol = MkSymbol {-# UNPACK #-} !Int -- identity + {-# UNPACK #-} !Int -- 1st hash + [Int] -- other hashes + String -- name + +instance Show Symbol where + show (MkSymbol i h _ s) = "<" ++ show i ++ "," ++ show h ++ ">" ++ s + +instance Eq Symbol where + MkSymbol i1 _ _ _ == MkSymbol i2 _ _ _ = i1 == i2 + +instance Ord Symbol where + MkSymbol i1 c1 cs1 _ `compare` MkSymbol i2 c2 cs2 _ + | i1 == i2 = EQ + | otherwise = + case c1 `compare` c2 of + EQ -> cs1 `compare` cs2 + ans -> ans + +-- | Turn a 'String' into a 'Symbol'. +-- +-- Note, however, that this function contains a space leak. It has +-- internal state (the symbol table) but is referentially transparent. +-- Unfortunately, there is no way to delete items from the symbol +-- table. +-- +-- (This function is, of course, thread-safe.) +intern :: String -> Symbol +intern = + unsafePerformIO $ + do tab <- newIORef (SymTbl 0 M.empty) + return $ \s -> + unsafePerformIO $ + atomicModifyIORef tab $ \tbl@(SymTbl n t) -> + case M.lookup s t of + Just sym -> (tbl, sym) + + Nothing -> + let n' = n + 1 + sym = mkSymbol n s + in (SymTbl n' (M.insert s sym t), sym) +{-# NOINLINE intern #-} + +-- ------------------------------------------------------------------- +-- TODO: Use a trie? Or a hash table? +data SymTbl = SymTbl !Int !(M.Map String Symbol) + +mkSymbol :: Int -> String -> Symbol +mkSymbol sym_identity str = MkSymbol sym_identity h hashes str + where + ints = map ord str + (h:hashes) = [ hash p ints | p <- bigprimes ] + +--------------------------------------------------------------------------- +-- hash stuff + +hash :: Int -> [Int] -> Int +hash p [] = 0 +hash p (i:is) = i + p * hash p is + +-- Note: While these aren't very efficient it is unlikely that more +-- than the first couple of elements are ever evaluated during the +-- whole run of a program. +primes, bigprimes :: [Int] +primes = 2 : [ n | n <- [3..], all (n !/) (takeWhile (<= sqr n) primes) ] + where + a !/ b = a `mod` b /= 0 + sqr = floor . sqrt . fromIntegral + +bigprimes = dropWhile (<= 258) primes + diff --git a/Data/Atom/UF.hs b/Data/Atom/UF.hs new file mode 100644 --- /dev/null +++ b/Data/Atom/UF.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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(..) ) +where + +import Data.Word ( Word32 ) +import Data.Char ( ord ) +import Data.Bits ( xor ) +import Data.IORef +import System.IO.Unsafe +import Control.Monad -- ( unless ) +import System.Mem.Weak +import System.Mem +import Data.Maybe + +-- ------------------------------------------------------------------- +-- 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 + +-- | Create a new local symbol. For best performance use +-- 'internInto' together with a symbol table / map. +intern :: String -> Symbol + +class SymTab s where + lookupSymbol :: s -> String -> Maybe Symbol + insertSymbol :: String -> Symbol -> s -> s + +-- | Insert a symbol into an existing table. +internInto :: SymTab s => s -> String -> (s, Symbol) + +-- ------------------------------------------------------------------- +-- Internals + +data SymbolInfo = + SymInfo {-# UNPACK #-} !Word32 -- hash + {-# UNPACK #-} !(IORef Link) -- parent [really unpack]? + String + +type Link = Maybe SymbolInfo + + +internInto st str = + case lookupSymbol st str of + Just sym -> (st, sym) + _ -> let sym = intern 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 + +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. + return EQ + + -- 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 + +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' + +test1 = do + let s1@(Symbol r1) = intern "foo" + s2@(Symbol r2) = intern "foo" + print $ r1 == r2 -- should be False + + -- create a weak reference to the second symbol, so we can observe + -- when it is garbage collected + w <- mk_weak =<< readIORef r2 + + print $ s1 == s2 -- should print True + print =<< liftM2 sameSym (readIORef r1) (readIORef r2) -- should print True + putStrLn "GCing" + performGC -- this should print goodbye, representing the + -- fact that the second symbol has been garbage + -- collected. + print . isJust =<< deRefWeak w -- should print False (object has been collected) + where + mk_weak o = mkWeakPtr o (Just (putStrLn "goodbye")) + +-- ------------------------------------------------------------------- + +-- 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) + where + magic_start = 2166136261 :: Word32 + go :: Word32 -> [Int] -> Word32 + go !h [] = h + go !h (c:cs) = + go ((h * 16777619) `xor` fromIntegral c) cs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Paradox/Equinox -- Copyright (c) 2003-2007, Koen Claessen, Niklas Sorensson + +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: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +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. 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/simple-atom.cabal b/simple-atom.cabal new file mode 100644 --- /dev/null +++ b/simple-atom.cabal @@ -0,0 +1,32 @@ +Name: simple-atom +Version: 0.1.0.1 +License: BSD3 +License-File: LICENSE +Author: Koen Claessen, Niklas Sorensson +Maintainer: Thomas Schilling +Homepage: http://github.com/nominolo/simple-atom +Synopsis: Atom (or symbol) datatype for fast comparision and sorting. +Description: + 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. + +Category: Data, Compilers/Interpreters, Parsing +Stability: provisional +Build-Type: Simple +Cabal-Version: >= 1.6 + +Library + Build-Depends: + base >= 3.0 && < 4.7, + containers >= 0.2 && < 0.6 + + exposed-modules: + Data.Atom.Simple + Data.Atom.UF