simple-atom (empty) → 0.1.0.1

raw patch · 5 files changed

+468/−0 lines, 5 filesdep +basedep +containerssetup-changed

Dependencies added: base, containers

Files

• Data/Atom/Simple.hs +107/−0
• Data/Atom/UF.hs +307/−0
• LICENSE +20/−0
• Setup.hs +2/−0
• simple-atom.cabal +32/−0

@@ -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+

@@ -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+-- <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(..) )+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

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <nominolo@googlemail.com>+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