diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,22 @@
+The MIT License (MIT)
+
+Copyright (c) 2015 Michael Schröder
+
+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/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,10 @@
+A contention-free STM hash map for Haskell.
+
+"Contention-free" means that the map will never cause spurious conflicts.
+A transaction operating on the map will only ever have to retry if
+another transaction is operating on the same key at the same time.
+
+This is an implementation of the *transactional trie*,
+which is basically a *lock-free concurrent hash trie* lifted into STM.
+For a detailed discussion, including an evaluation of its performance,
+see Chapter 4 of [my master's thesis](https://github.com/mcschroeder/thesis).
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/benchmarks/Bench.hs b/benchmarks/Bench.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/Bench.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import BenchGen
+import Control.Applicative
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Concurrent.STM.Stats
+import Control.DeepSeq
+import Control.Exception (evaluate)
+import Control.Monad
+import Control.Monad.IO.Class
+import CriterionPlus
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Generics
+import GHC.Stats
+import System.Environment
+import System.Mem
+import System.Random.MWC
+import System.Random.MWC.CondensedTable
+import Text.Printf
+
+import qualified Control.Concurrent.STM.Map as TTrie
+import qualified STMContainers.Map as STMCont
+import qualified Data.HashMap.Strict as HashMap
+
+------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+    (arg1:arg2:arg3:arg4:arg5:args) <- getArgs
+    printf "threads = %s\n"         arg1
+    printf "numTransactions = %s\n" arg2
+    printf "sizes = %s\n"           arg3
+    printf "numPrefill = %s\n"      arg4
+    printf "ops = %s\n"             arg5
+    let threads            = read arg1 :: [Int]
+        numTransactions    = read arg2
+        sizes              = mkTable $ read arg3
+        numPrefill         = read arg4
+        (ins,upd,look,del) = read arg5
+        config = Config
+            { operations = mkTable [ (Insert, ins + upd)
+                                   , (Lookup, look)
+                                   , (Delete, del)
+                                   ]
+            , keys = \op -> case op of
+                Insert -> mkTable [(remember key, ins), (remember (reuse key), upd)]
+                Lookup -> mkTable [(reuse key, 1)]
+                Delete -> mkTable [(forget (reuse key), 1)]
+            }
+
+    (ks,txs) <- genTransactions numPrefill numTransactions sizes config
+    withArgs args $ benchmark
+                  $ standoff (T.pack arg5)
+                  $ mapM_ (supergroup ks txs numTransactions)
+                  $ threads
+
+supergroup :: [Key] -> [Transaction] -> Int -> Int -> Standoff ()
+supergroup ks txs numTransactions t =
+    group (T.pack $ printf "%d/%d" t n) $ do
+        runAll "unordered-containers" hashmapPrefill hashmapEval
+        runAll "stm-containers"       stmcontPrefill stmcontEval
+        runAll "ttrie"                ttriePrefill  ttrieEval
+  where
+    n = numTransactions `div` t
+    ops = split n txs
+    runAll name prefill eval = do
+        runTime name prefill eval ks ops
+        liftIO $ runRetries (printf "%d/%d/%s" t n name) prefill eval ks ops
+        liftIO $ runAlloc prefill eval ks ops
+
+split :: Int -> [a] -> [[a]]
+split n [] = []
+split n xs = let (ys,zs) = splitAt n xs in ys : split n zs
+
+------------------------------------------------------------------------------
+
+type EvalFunc c = Op -> Key -> c -> STM ()
+type PrefillFunc c = [Key] -> IO c
+
+runTime :: String -> PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> Standoff ()
+runTime name prefill eval ks ops = subject (T.pack name) $ do
+    pause
+    c <- liftIO $ prefill ks
+    continue
+    liftIO $ run_ atomically ops eval c
+
+runRetries :: String -> PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> IO ()
+runRetries name prefill eval ks ops = do
+    printf "commits: "
+    c <- prefill ks
+    let atomically' = trackSTMConf defaultTrackSTMConf
+                        { tryThreshold = Nothing
+                        , globalTheshold = Nothing
+                        }
+    run_ (atomically' name) ops eval c
+    stats <- getSTMStats
+    let Just (commits, retries) = Map.lookup name stats
+    printf "%d\nretries: %d\n" commits retries
+
+runAlloc :: PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> IO ()
+runAlloc prefill eval ks ops = do
+    printf "allocated bytes: "
+    c <- prefill ks
+    performGC
+    before <- getGCStats
+    run_ atomically ops eval c
+    performGC
+    after <- getGCStats
+    let bytes = bytesAllocated after - bytesAllocated before
+    printf "%d\n" bytes
+
+run_ :: (STM () -> IO ()) -> [[Transaction]] -> EvalFunc c -> c -> IO ()
+run_ atom ops f c = void $ mapConcurrently (mapM_ txEval) ops
+  where txEval = atom . mapM_ (\(op,k) -> f op k c)
+
+------------------------------------------------------------------------------
+
+type Key = Text
+type Transaction = [(Op,Key)]
+
+data Op = Lookup | Insert | Delete
+    deriving (Eq, Show, Generic)
+
+instance NFData Op
+
+key :: Generator IO k Key
+key = do
+    n <- liftGen $ genFromTable length
+    T.pack <$> replicateM n (liftGen $ genFromTable alphabet)
+  where
+    length = mkTable $ zip [7..20] (repeat 1)
+    alphabet = mkTable $ zip ['a'..'z'] (repeat 1)
+
+genTransactions :: Int -> Int -> CondensedTableV Int -> Config IO Op Key -> IO ([Key],[Transaction])
+genTransactions numPrefill numTransactions sizes config = do
+    gen <- create
+    runGenerator gen $ do
+        liftIO $ printf "Generating %d random keys to prefill...\n" numPrefill
+        ks <- replicateM numPrefill (remember key)
+        liftIO $ printf "Generating %d random transactions...\n" numTransactions
+        txs <- replicateM numTransactions $ do
+            size <- liftGen $ genFromTable sizes
+            generateOperations config size
+        return (ks,txs)
+
+------------------------------------------------------------------------------
+-- Evaluation and Prefill functions
+
+instance (NFData k, NFData v) => NFData (TTrie.Map k v)
+
+ttriePrefill :: PrefillFunc (TTrie.Map Key ())
+ttriePrefill ks = do
+  m <- atomically $ TTrie.empty
+  forM_ ks $ \k -> atomically $ TTrie.insert k () m
+  evaluate (rnf m)
+  return m
+
+ttrieEval :: EvalFunc (TTrie.Map Key ())
+ttrieEval Lookup k = void . TTrie.lookup k
+ttrieEval Insert k = TTrie.insert k ()
+ttrieEval Delete k = TTrie.delete k
+
+instance (NFData k, NFData v) => NFData (STMCont.Map k v)
+
+stmcontPrefill :: PrefillFunc (STMCont.Map Key ())
+stmcontPrefill ks = do
+  m <- atomically $ STMCont.new
+  forM_ ks $ \k -> atomically $ STMCont.insert () k m
+  evaluate (rnf m)
+  return m
+
+stmcontEval :: EvalFunc (STMCont.Map Key ())
+stmcontEval Lookup k = void . STMCont.lookup k
+stmcontEval Insert k = STMCont.insert () k
+stmcontEval Delete k = STMCont.delete k
+
+instance (NFData a) => NFData (TVar a)
+
+hashmapPrefill :: PrefillFunc (TVar (HashMap.HashMap Key (TVar ())))
+hashmapPrefill ks = do
+  elems <- forM ks (\k -> newTVarIO () >>= \v -> return (k,v))
+  m <- newTVarIO $ HashMap.fromList elems
+  evaluate (rnf m)
+  return m
+
+hashmapEval :: EvalFunc (TVar (HashMap.HashMap Key (TVar ())))
+hashmapEval Lookup k m = do
+  v <- HashMap.lookup k <$> readTVar m
+  case v of
+    Just v -> void $ readTVar v
+    Nothing -> return ()
+hashmapEval Insert k m = do
+  v <- newTVar ()
+  modifyTVar' m (HashMap.insert k v)
+hashmapEval Delete k m = modifyTVar' m (HashMap.delete k)
diff --git a/benchmarks/BenchGen.hs b/benchmarks/BenchGen.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/BenchGen.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module BenchGen where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Primitive
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Strict
+import Data.Bifunctor
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Vector as V
+import System.Random.MWC
+import System.Random.MWC.CondensedTable
+
+------------------------------------------------------------------------------
+
+newtype Generator m k a = Generator { unG :: StateT (Gen (PrimState m), Set k) m a }
+  deriving (Functor, Applicative, Monad)
+
+instance MonadIO m => MonadIO (Generator m k) where
+    liftIO = Generator . liftIO
+
+runGenerator :: PrimMonad m => Gen (PrimState m) -> Generator m k a -> m a
+runGenerator gen (Generator m) = evalStateT m (gen, Set.empty)
+
+liftGen :: PrimMonad m => (Gen (PrimState m) -> m a) -> Generator m k a
+liftGen f = Generator $ lift . f =<< gets fst
+
+reuse :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k
+reuse keygen = Generator $ do
+    (gen,ks) <- get
+    if Set.null ks
+        then unG keygen
+        else do
+            i <- lift $ uniformR (0, Set.size ks - 1) gen
+            return $ Set.elemAt i ks
+
+remember :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k
+remember keygen = Generator $ do
+    k <- unG keygen
+    modify (second $ Set.insert k)
+    return k
+
+forget :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k
+forget keygen = Generator $ do
+    k <- unG keygen
+    modify (second $ Set.delete k)
+    return k
+
+------------------------------------------------------------------------------
+
+data Config m op k = Config { operations :: CondensedTableV op
+                            , keys :: op -> CondensedTableV (Generator m k k)
+                            }
+
+generateOperations :: (PrimMonad m, Ord k)
+                   => Config m op k
+                   -> Int
+                   -> Generator m k [(op,k)]
+generateOperations config n =
+    replicateM n $ do
+        op <- liftGen $ genFromTable (operations config)
+        k <- join $ liftGen $ genFromTable $ (keys config) op
+        return (op,k)
+
+------------------------------------------------------------------------------
+
+mkTable :: [(a,Double)] -> CondensedTableV a
+mkTable = tableFromWeights . V.fromList
diff --git a/benchmarks/run.sh b/benchmarks/run.sh
new file mode 100644
--- /dev/null
+++ b/benchmarks/run.sh
@@ -0,0 +1,30 @@
+#!/bin/bash
+
+main() {
+    THREADS="[1,2,4,6,8,10,12,14,16]"
+    TX_SIZE="[(1,1),(2,1),(3,1),(4,1),(5,1)]"
+    NUM_TX="200000"
+    NUM_PREFILL="1000000"
+
+    mkdir -p "results/1"
+    bench $THREADS $NUM_TX "[(1,1)]" 0       "(1,0,0,0)" "results/1/insert"
+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,1,0,0)" "results/1/update"
+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,0,1,0)" "results/1/lookup"
+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,0,0,1)" "results/1/delete"
+
+    mkdir -p "results/5"
+    bench $THREADS $NUM_TX $TX_SIZE 0            "(70,10,10,10)" "results/update/5/insert"
+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,70,10,10)" "results/update/5/update"
+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,10,70,10)" "results/update/5/lookup"
+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,10,10,70)" "results/update/5/delete"    
+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(25,25,25,25)" "results/update/5/balanced-prefill"
+
+#    sudo shutdown -h now
+}
+
+bench() {
+    unbuffer cabal bench bench --benchmark-options="$1 $2 $3 $4 $5 +RTS -T" | tee "$6.txt"
+#    curl -F $6.txt=@$6.txt https://XXXXXXXXXXXXXXX@neocities.org/api/upload
+}
+
+main "$@"
diff --git a/src/Control/Concurrent/STM/Map.hs b/src/Control/Concurrent/STM/Map.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Concurrent/STM/Map.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE PatternGuards #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+-----------------------------------------------------------------------
+-- | A contention-free STM hash map.
+-- \"Contention-free\" means that the map will never cause spurious conflicts.
+-- A transaction operating on the map will only ever have to retry if
+-- another transaction is operating on the same key at the same time.
+-----------------------------------------------------------------------
+
+module Control.Concurrent.STM.Map
+    ( Map
+
+      -- * Construction
+    , empty
+
+      -- * Modification
+    , insert
+    , delete
+    , unsafeDelete
+
+      -- * Query
+    , lookup
+    , phantomLookup
+    ) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Atomics
+import Data.IORef
+import Data.Maybe
+import GHC.Conc.Sync (unsafeIOToSTM)
+import Prelude hiding (lookup)
+
+import Data.SparseArray
+
+-----------------------------------------------------------------------
+
+-- | A map from keys @k@ to values @v@.
+newtype Map k v = Map (INode k v)
+
+type INode k v = IORef (Node k v)
+
+data Node k v = Array !(SparseArray (Branch k v))
+              | List  ![Leaf k v]
+              | Tomb  !(Leaf k v)
+
+data Branch k v = I !(INode k v)
+                | L !(Leaf k v)
+
+data Leaf k v = Leaf !k !(TVar (Maybe v))
+
+-----------------------------------------------------------------------
+
+-- | /O(1)/. Construct an empty map.
+empty :: STM (Map k v)
+empty = unsafeIOToSTM $ Map <$> newIORef (Array emptyArray)
+{-# INLINE empty #-}
+
+-- | /O(log n)/. Associate the given value with the given key.
+-- If the key is already present in the map, the old value is replaced.
+insert :: (Eq k, Hashable k) => k -> v -> Map k v -> STM ()
+insert k v m = do var <- getTVar k m
+                  writeTVar var (Just v)
+{-# INLINABLE insert #-}
+
+-- | /O(log n)/. Return the value associated with the given key, or 'Nothing'.
+--
+-- __Note__: This might increase the map's memory consumption
+-- by putting the key into the map.
+-- If that is not acceptable, use 'phantomLookup'.
+lookup :: (Eq k, Hashable k) => k -> Map k v -> STM (Maybe v)
+lookup k m = do var <- getTVar k m
+                readTVar var
+{-# INLINABLE lookup #-}
+
+-- | /O(log n)/. Remove the value associated with a given key from the map,
+-- if present.
+--
+-- __Note__: This does not actually remove the key from the map.
+-- In fact, it might actually increase the map's memory consumption
+-- by putting the key into the map.
+-- To completely delete an entry, including its key, use 'unsafeDelete'.
+delete :: (Eq k, Hashable k) => k -> Map k v -> STM ()
+delete k m = do var <- getTVar k m
+                writeTVar var Nothing
+{-# INLINABLE delete #-}
+
+-----------------------------------------------------------------------
+
+getTVar :: (Eq k, Hashable k) => k -> Map k v -> STM (TVar (Maybe v))
+getTVar k (Map root) = go root 0 undefined
+  where
+    h = hash k
+
+    go inode level parent = do
+        ticket <- unsafeIOToSTM $ readForCAS inode
+        case peekTicket ticket of
+            Array a -> case arrayLookup level h a of
+                Just (I inode2) -> go inode2 (down level) inode
+                Just (L leaf2@(Leaf k2 var))
+                    | k == k2   -> return var
+                    | otherwise -> cas inode ticket (growTrie level a (hash k2) leaf2)
+                Nothing         -> cas inode ticket (insertLeaf level a)
+            List xs -> case listLookup k xs of
+                Just var        -> return var
+                Nothing         -> cas inode ticket (return . List . (:xs))
+            Tomb _  -> unsafeIOToSTM (clean parent (up level)) >> go root 0 undefined
+
+    cas inode ticket f = do
+        var <- newTVar Nothing
+        node <- f (Leaf k var)
+        (ok,_) <- unsafeIOToSTM $ casIORef inode ticket node
+        if ok then return var
+              else go root 0 undefined
+
+    insertLeaf level a leaf = do
+        let a' = arrayInsert level h (L leaf) a
+        return (Array a')
+
+    growTrie level a h2 leaf2 leaf1 = do
+        inode2 <- unsafeIOToSTM $ combineLeaves (down level) h leaf1 h2 leaf2
+        let a' = arrayUpdate level h (I inode2) a
+        return (Array a')
+
+    combineLeaves level h1 leaf1 h2 leaf2
+        | level >= lastLevel = newIORef (List [leaf1, leaf2])
+        | otherwise =
+            case mkPair level h (L leaf1) h2 (L leaf2) of
+                Just pair -> newIORef (Array pair)
+                Nothing -> do
+                    inode <- combineLeaves (down level) h1 leaf1 h2 leaf2
+                    let a = mkSingleton level h (I inode)
+                    newIORef (Array a)
+
+{-# INLINE getTVar #-}
+
+
+-- | /O(log n)/. Return the value associated with the given key, or 'Nothing'.
+--
+-- In contrast to 'lookup', this will never increase the map's memory consumption.
+-- However, it might allow /phantom reads/ to occur.
+-- Consider the following situation:
+--
+-- > f = atomically $ do v1 <- phantomLookup k m
+-- >                     v2 <- phantomLookup k m
+-- >                     return (v1 == v2)
+--
+-- Under certain circumstances @f@ might actually return @False@, in particular
+-- if the first @phantomLookup@ happens on an empty map
+-- and some other transaction inserts a value for @k@ before the second call
+-- to @phantomLookup@.
+phantomLookup :: (Eq k, Hashable k) => k -> Map k v -> STM (Maybe v)
+phantomLookup k (Map root) = go root 0 undefined
+  where
+    h = hash k
+    go inode level parent = do
+        node <- unsafeIOToSTM $ readIORef inode
+        case node of
+            Array a -> case arrayLookup level h a of
+                Just (I inode2) -> go inode2 (down level) inode
+                Just (L (Leaf k2 var))
+                    | k == k2   -> readTVar var
+                    | otherwise -> return Nothing
+                Nothing         -> return Nothing
+            List xs -> case listLookup k xs of
+                Just var -> readTVar var
+                Nothing  -> return Nothing
+            Tomb _  -> unsafeIOToSTM (clean parent (up level)) >> go root 0 undefined
+
+{-# INLINABLE phantomLookup #-}
+
+
+-- | /O(log n)/. This will completely remove a given key
+-- and its associated value from the map, if present.
+-- This is not an atomic operation, however. __Use with caution!__
+unsafeDelete :: (Eq k, Hashable k) => k -> Map k v -> IO ()
+unsafeDelete k m@(Map root) = do
+    ok <- go root 0 undefined
+    unless ok (unsafeDelete k m)
+  where
+    h = hash k
+    go inode level parent = do
+        ticket <- readForCAS inode
+        case peekTicket ticket of
+            Array a -> do
+                ok <- case arrayLookup level h a of
+                    Just (I inode2) -> go inode2 (down level) inode
+                    Just (L (Leaf k2 _))
+                        | k == k2   -> casArrayDelete inode ticket level a
+                        | otherwise -> return True
+                    Nothing         -> return True
+                when ok (compressIfPossible level inode parent)
+                return ok
+            List xs -> casListDelete inode ticket xs
+            Tomb _  -> clean parent (up level) >> return False
+
+    compressIfPossible level inode parent = do
+        n <- readIORef inode
+        case n of
+            Tomb _ -> cleanParent parent inode h (up level)
+            _      -> return ()
+
+    casArrayDelete inode ticket level a = do
+        let a' = arrayDelete level h a
+            n  = contract level (Array a')
+        (ok,_) <- casIORef inode ticket n
+        return ok
+
+    casListDelete inode ticket xs = do
+        let xs' = listDelete k xs
+            n | [l] <- xs' = Tomb l
+              | otherwise  = List xs'
+        (ok,_) <- casIORef inode ticket n
+        return ok
+
+{-# INLINABLE unsafeDelete #-}
+
+-----------------------------------------------------------------------
+
+clean :: INode k v -> Level -> IO ()
+clean inode level = do
+    ticket <- readForCAS inode
+    case peekTicket ticket of
+        n@(Array _) -> do
+            n' <- compress level n
+            void $ casIORef inode ticket n'
+        _ -> return ()
+{-# INLINE clean #-}
+
+cleanParent :: INode k v -> INode k v -> Hash -> Level -> IO ()
+cleanParent parent inode h level = do
+    ticket <- readForCAS parent
+    case peekTicket ticket of
+        n@(Array a) -> case arrayLookup level h a of
+            Just (I inode2) | inode2 == inode -> do
+                n2 <- readIORef inode
+                case n2 of
+                    Tomb _ -> do
+                        n' <- compress level n
+                        (ok,_) <- casIORef parent ticket n'
+                        unless ok $ cleanParent parent inode h level
+                    _ -> return ()
+            _ -> return ()
+        _ -> return ()
+
+compress :: Level -> Node k v -> IO (Node k v)
+compress level (Array a) = contract level . Array <$> arrayMapM resurrect a
+compress _     n         = return n
+{-# INLINE compress #-}
+
+resurrect :: Branch k v -> IO (Branch k v)
+resurrect b@(I inode) = do n <- readIORef inode
+                           case n of
+                               Tomb leaf -> return (L leaf)
+                               _         -> return b
+resurrect b           = return b
+{-# INLINE resurrect #-}
+
+contract :: Level -> Node k v -> Node k v
+contract level (Array a) | level > 0
+                         , Just (L leaf) <- arrayToMaybe a
+                         = Tomb leaf
+contract _     n         = n
+{-# INLINE contract #-}
+
+-----------------------------------------------------------------------
+
+listLookup :: Eq k => k -> [Leaf k v] -> Maybe (TVar (Maybe v))
+listLookup k1 = go
+  where
+    go []                             = Nothing
+    go (Leaf k2 var : xs) | k1 == k2  = Just var
+                          | otherwise = go xs
+
+listDelete :: Eq k => k -> [Leaf k v] -> [Leaf k v]
+listDelete k1 = go
+  where
+    go [] = []
+    go (x@(Leaf k2 _):xs) | k1 == k2  = xs
+                          | otherwise = x : go xs
diff --git a/src/Data/SparseArray.hs b/src/Data/SparseArray.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/SparseArray.hs
@@ -0,0 +1,192 @@
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+module Data.SparseArray
+    ( SparseArray
+    , Hashable, Hash, hash
+    , Level, down, up, lastLevel
+    , emptyArray, mkSingleton, mkPair
+    , arrayLookup, arrayInsert, arrayUpdate, arrayDelete
+    , arrayMapM, arrayToMaybe
+    ) where
+
+import Control.Monad.ST
+import Data.Bits
+import Data.Hashable (Hashable)
+import qualified Data.Hashable as H
+import Data.Primitive.Array
+import Data.Word
+import Prelude hiding (lookup, mapM)
+
+-----------------------------------------------------------------------
+
+data SparseArray a = SparseArray !Bitmap !(Array a)
+
+type Bitmap = Word
+type Hash   = Word
+type Level  = Int
+
+-----------------------------------------------------------------------
+
+emptyArray :: SparseArray a
+emptyArray = SparseArray 0 arr
+  where
+    arr = runST $ do
+        marr <- newArray 0 undefined
+        unsafeFreezeArray marr
+
+{-# INLINE emptyArray #-}
+
+mkSingleton :: Level -> Hash -> a -> SparseArray a
+mkSingleton level h a = SparseArray bmp arr
+  where
+    i   = index level h
+    bmp = unsafeShiftL 1 i
+    arr = runST $ do
+        marr <- newArray 1 a
+        unsafeFreezeArray marr
+
+{-# INLINE mkSingleton #-}
+
+mkPair :: Level -> Hash -> a -> Hash -> a -> Maybe (SparseArray a)
+mkPair level h1 a1 h2 a2 =
+    case compare i1 i2 of
+        LT -> Just $ SparseArray bmp (pair a1 a2)
+        GT -> Just $ SparseArray bmp (pair a2 a1)
+        EQ -> Nothing
+  where
+    i1  = index level h1
+    i2  = index level h2
+    bmp = (unsafeShiftL 1 i1) .|. (unsafeShiftL 1 i2)
+    pair x y = runST $ do
+        marr <- newArray 2 undefined
+        writeArray marr 0 x
+        writeArray marr 1 y
+        unsafeFreezeArray marr
+
+{-# INLINE mkPair #-}
+
+arrayLookup :: Level -> Hash -> SparseArray a -> Maybe a
+arrayLookup level h (SparseArray bmp arr)
+    | bmp .&. m == 0 = Nothing
+    | otherwise      = Just (indexArray arr i)
+  where
+    m = mask level h
+    i = sparseIndex bmp m
+
+{-# INLINE arrayLookup #-}
+
+arrayInsert :: Level -> Hash -> a -> SparseArray a -> SparseArray a
+arrayInsert level h a (SparseArray bmp arr) = SparseArray bmp' arr'
+  where
+    n    = popCount bmp
+    m    = mask level h
+    i    = sparseIndex bmp m
+    bmp' = bmp .|. m
+    arr' = runST $ do
+        marr <- newArray (n+1) undefined
+        copyArray marr 0 arr 0 i
+        writeArray marr i a
+        copyArray marr (i+1) arr i (n-i)
+        unsafeFreezeArray marr
+
+{-# INLINE arrayInsert #-}
+
+arrayUpdate :: Level -> Hash -> a -> SparseArray a -> SparseArray a
+arrayUpdate level h a (SparseArray bmp arr) = SparseArray bmp arr'
+  where
+    n = popCount bmp
+    m = mask level h
+    i = sparseIndex bmp m
+    arr' = runST $ do
+        marr <- newArray n undefined
+        copyArray marr 0 arr 0 n
+        writeArray marr i a
+        unsafeFreezeArray marr
+
+{-# INLINE arrayUpdate #-}
+
+arrayDelete :: Level -> Hash -> SparseArray a -> SparseArray a
+arrayDelete level h (SparseArray bmp arr) = SparseArray bmp' arr'
+  where
+    n    = popCount bmp
+    m    = mask level h
+    i    = sparseIndex bmp m
+    bmp' = bmp `xor` m
+    arr' = runST $ do
+        marr <- newArray (n-1) undefined
+        copyArray marr 0 arr 0 i
+        copyArray marr i arr (i+1) (n-(i+1))
+        unsafeFreezeArray marr
+
+{-# INLINE arrayDelete #-}
+
+arrayMapM :: (a -> IO a) -> SparseArray a -> IO (SparseArray a)
+arrayMapM f = \(SparseArray bmp arr) -> do
+    let n = popCount bmp
+    marr <- newArray n undefined
+    go n arr marr 0
+    arr' <- unsafeFreezeArray marr
+    return (SparseArray bmp arr')
+  where
+    go n arr marr i
+        | i >= n = return ()
+        | otherwise = do
+            x <- indexArrayM arr i
+            writeArray marr i =<< f x
+            go n arr marr (i+1)
+
+{-# INLINE arrayMapM #-}
+
+arrayToMaybe :: SparseArray a -> Maybe a
+arrayToMaybe (SparseArray bmp arr) =
+    case popCount bmp of
+        1 -> Just $ indexArray arr 0
+        _ -> Nothing
+
+{-# INLINE arrayToMaybe #-}
+
+-----------------------------------------------------------------------
+
+hash :: Hashable a => a -> Hash
+hash = fromIntegral . H.hash
+{-# INLINE hash #-}
+
+hashLength :: Int
+hashLength = finiteBitSize (undefined :: Word)
+{-# INLINE hashLength #-}
+
+bitsPerSubkey :: Int
+bitsPerSubkey = floor . logBase (2 :: Float) . fromIntegral $ hashLength
+{-# INLINE bitsPerSubkey #-}
+
+subkeyMask :: Bitmap
+subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1
+{-# INLINE subkeyMask #-}
+
+down :: Level -> Level
+down = (+) bitsPerSubkey
+{-# INLINE down #-}
+
+up :: Level -> Level
+up = subtract bitsPerSubkey
+{-# INLINE up #-}
+
+lastLevel :: Level
+lastLevel = hashLength
+{-# INLINE lastLevel #-}
+
+index :: Level -> Hash -> Int
+index level h = fromIntegral $ (h `unsafeShiftR` level) .&. subkeyMask
+{-# INLINE index #-}
+
+-- when or-ed with a bitmap, determines if the hash is present
+-- in the array at the given level of the trie
+mask :: Level -> Hash -> Bitmap
+mask level h = 1 `unsafeShiftL` index level h
+{-# INLINE mask #-}
+
+-- position in the array
+sparseIndex :: Bitmap -> Bitmap -> Int
+sparseIndex bmp m = popCount ((m - 1) .&. bmp)
+{-# INLINE sparseIndex #-}
+
diff --git a/ttrie.cabal b/ttrie.cabal
new file mode 100644
--- /dev/null
+++ b/ttrie.cabal
@@ -0,0 +1,51 @@
+name:                ttrie
+version:             0.1
+synopsis:            Contention-free STM hash map
+description:
+  A contention-free STM hash map.
+  \"Contention-free\" means that the map will never cause spurious conflicts.
+  A transaction operating on the map will only ever have to retry if
+  another transaction is operating on the same key at the same time.
+  .
+  This is an implementation of the /transactional trie/,
+  which is basically a /lock-free concurrent hash trie/ lifted into STM.
+  For a detailed discussion, including an evaluation of its performance,
+  see Chapter 4 of <https://github.com/mcschroeder/thesis my master's thesis>.
+homepage:            http://github.com/mcschroeder/ttrie
+bug-reports:         http://github.com/mcschroeder/ttrie/issues
+license:             MIT
+license-file:        LICENSE
+author:              Michael Schröder
+maintainer:          mc.schroeder@gmail.com
+copyright:           (c) 2014-2015 Michael Schröder
+category:            Concurrency
+build-type:          Simple
+extra-source-files:  README.md, benchmarks/run.sh
+cabal-version:       >=1.10
+
+source-repository head
+  type: git
+  location: https://github.com/mcschroeder/ttrie.git
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Control.Concurrent.STM.Map
+  other-modules:       Data.SparseArray
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+  build-depends:       base >=4.7 && <4.8
+                     , atomic-primops >=0.6
+                     , hashable >=1.2
+                     , primitive >=0.5
+                     , stm >=2
+
+benchmark bench
+  hs-source-dirs:      benchmarks
+  main-is:             Bench.hs
+  other-modules:       BenchGen
+  type:                exitcode-stdio-1.0
+  default-language:    Haskell2010
+  ghc-options:         -O2 -threaded -with-rtsopts=-N
+  build-depends:
+    base, async, bifunctors, containers, criterion-plus, deepseq, mwc-random, primitive, stm, stm-containers, stm-stats, text, transformers, ttrie, unordered-containers, vector
+