vcache (empty) → 0.1

raw patch · 28 files changed

+4341/−0 lines, 28 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, direct-murmur-hash, easy-file, filelock, lmdb, random, stm, transformers

Files

• LICENSE +24/−0
• Setup.hs +3/−0
• hsrc_lib/Database/VCache.hs +23/−0
• hsrc_lib/Database/VCache/Aligned.hs +41/−0
• hsrc_lib/Database/VCache/Alloc.hs +553/−0
• hsrc_lib/Database/VCache/Cache.hs +78/−0
• hsrc_lib/Database/VCache/Clean.hs +216/−0
• hsrc_lib/Database/VCache/Hash.hs +23/−0
• hsrc_lib/Database/VCache/Open.hs +246/−0
• hsrc_lib/Database/VCache/PVar.hs +112/−0
• hsrc_lib/Database/VCache/Path.hs +54/−0
• hsrc_lib/Database/VCache/RWLock.hs +146/−0
• hsrc_lib/Database/VCache/Read.hs +92/−0
• hsrc_lib/Database/VCache/Refct.hs +45/−0
• hsrc_lib/Database/VCache/Stats.hs +93/−0
• hsrc_lib/Database/VCache/Sync.hs +19/−0
• hsrc_lib/Database/VCache/Types.hs +663/−0
• hsrc_lib/Database/VCache/VCacheable.hs +178/−0
• hsrc_lib/Database/VCache/VGet.hs +329/−0
• hsrc_lib/Database/VCache/VGetAux.hs +98/−0
• hsrc_lib/Database/VCache/VGetInit.hs +80/−0
• hsrc_lib/Database/VCache/VPut.hs +224/−0
• hsrc_lib/Database/VCache/VPutAux.hs +120/−0
• hsrc_lib/Database/VCache/VPutFini.hs +101/−0
• hsrc_lib/Database/VCache/VRef.hs +123/−0
• hsrc_lib/Database/VCache/VTx.hs +86/−0
• hsrc_lib/Database/VCache/Write.hs +494/−0
• vcache.cabal +77/−0

@@ -0,0 +1,24 @@+Copyright (c) 2014, David Barbour+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT HOLDER OR 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.+

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

@@ -0,0 +1,23 @@+++module Database.VCache+    ( module Database.VCache.VRef+    , module Database.VCache.PVar+    , module Database.VCache.VTx+    , VCache, openVCache+    , VSpace, vcache_space+    , module Database.VCache.Path+    , module Database.VCache.Stats+    , module Database.VCache.Sync +    , module Database.VCache.VCacheable+    ) where++import Database.VCache.Types +import Database.VCache.VCacheable+import Database.VCache.Open+import Database.VCache.Stats+import Database.VCache.Path+import Database.VCache.Sync+import Database.VCache.VRef+import Database.VCache.PVar+import Database.VCache.VTx

@@ -0,0 +1,41 @@+++-- aligned peek/poke variants. These are more expensive, but should+-- be much more portable to different machines. I might later use+-- #ifdef flags to transparently control alignment sensitivity if+-- this becomes a big performance issue.+module Database.VCache.Aligned+    ( peekAligned+    , pokeAligned+    ) where++import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr++-- | An alignment-sensitive peek; will copy data into aligned +-- memory prior to performing 'peek'.+peekAligned :: (Storable a) => Ptr a -> IO a+peekAligned = peekAligned' undefined+{-# INLINE peekAligned #-}++-- | An alignment-sensitive poke. Will poke data into aligned+-- memory then copy it into the destination memory.+pokeAligned :: (Storable a) => Ptr a -> a -> IO ()+pokeAligned = pokeAligned' undefined+{-# INLINE pokeAligned #-}++peekAligned' :: (Storable a) => a -> Ptr a -> IO a+peekAligned' _dummy pSrc = +    allocaBytesAligned (sizeOf _dummy) (alignment _dummy) $ \ pBuff -> do+        copyBytes pBuff pSrc (sizeOf _dummy)+        peek pBuff+{-# INLINE peekAligned' #-}++pokeAligned' :: (Storable a) => a -> Ptr a -> a -> IO ()+pokeAligned' _dummy pDst a =+    allocaBytesAligned (sizeOf _dummy) (alignment _dummy) $ \ pBuff -> do+        poke pBuff a+        copyBytes pDst pBuff (sizeOf _dummy)+{-# INLINE pokeAligned' #-}

@@ -0,0 +1,553 @@+{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}++-- | Constructors and Allocators for VRefs and PVars.+--+-- This module is the nexus of many concurrency concerns. Addresses+-- are GC'd, but structure sharing allows VRef addresses to revive+-- from zero references. Allocations might not be observed in the+-- LMDB layer databases for a couple frames. GC at the Haskell layer+-- must interact with ephemeron maps.+--+-- Because VRefs are frequently constructed by unsafePerformIO, and+-- PVars may be constructed via unsafePerformIO (newPVarIO), none of+-- these operations may use STM.+--+-- For now, I'm essentially using a global lock for managing these+-- in-memory tables. Since the LMDB layer is also limited by a single+-- writer, I think this lock shouldn't become a major bottleneck. But+-- it may require more context switching than desirable.+-- +module Database.VCache.Alloc+    ( addr2vref+    , addr2pvar+    , newVRefIO+    , newVRefIO'+    , initVRefCache+    , newPVar+    , newPVars+    , newPVarIO+    , newPVarsIO+    , loadRootPVar+    , loadRootPVarIO+    ) where++import Control.Exception+import Control.Monad+import Control.Applicative+import Data.Word+import Data.IORef+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.List as L+import qualified Data.Map.Strict as Map+import Data.Typeable+import Data.Maybe++import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc++import GHC.Conc (unsafeIOToSTM)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TVar ++import System.Mem.Weak (Weak)+import qualified System.Mem.Weak as Weak+import System.IO.Unsafe+import Unsafe.Coerce++import Database.LMDB.Raw++import Database.VCache.Types+import Database.VCache.Path+import Database.VCache.Aligned+import Database.VCache.VPutFini+import Database.VCache.Hash+import Database.VCache.Read++-- | Obtain a VRef given an address and value. Not initially cached.+-- This operation doesn't touch the persistence layer; it assumes the+-- given address is valid.+--+addr2vref :: (VCacheable a) => VSpace -> Address -> IO (VRef a)+addr2vref !vc !addr = +    assert (isVRefAddr addr) $ +    modifyMVarMasked (vcache_memory vc) $ +    addr2vref' vc addr+{-# INLINE addr2vref #-}++addr2vref' :: (VCacheable a) => VSpace -> Address -> Memory -> IO (Memory, VRef a)+addr2vref' !vc !addr !m = _addr2vref undefined vc addr m+{-# INLINE addr2vref' #-}++-- Since I'm partitioning VRefs based on whether they're cached, I +-- must search two maps to see whether the VRef is already in memory. +_addr2vref :: (VCacheable a) => a -> VSpace -> Address -> Memory -> IO (Memory, VRef a)+_addr2vref _dummy !vc !addr !m = do+    let ty = typeOf _dummy +    mbCacheE <- loadVRefCache addr ty (mem_evrefs m)+    case mbCacheE of+        Just cache -> return (m, VRef addr cache vc ty get)+        Nothing -> do+            mbCacheC <- loadVRefCache addr ty (mem_cvrefs m)+            case mbCacheC of+                Just cache -> return (m, VRef addr cache vc ty get)+                Nothing -> do+                    cache <- newIORef NotCached+                    e <- mkVREph vc addr cache ty+                    let m' = m { mem_evrefs = addVREph e (mem_evrefs m) }+                    m' `seq` return (m', VRef addr cache vc ty get)+{-# NOINLINE _addr2vref #-}++mkVREph :: VSpace -> Address -> IORef (Cache a) -> TypeRep -> IO VREph+mkVREph !vc !addr !cache !ty = +    mkWeakIORef cache (clearVRef vc addr ty) >>= \ wkCache ->+    return $! VREph addr ty wkCache+{-# INLINE mkVREph #-}++loadVRefCache :: Address -> TypeRep -> VREphMap -> IO (Maybe (IORef (Cache a)))+loadVRefCache !addr !ty !em = mbrun _getVREphCache mbf where+    mbf = Map.lookup addr em >>= Map.lookup ty+{-# INLINE loadVRefCache #-}++-- When a VRef is GC'd from the Haskell layer, we need to delete it+-- from the ephemeron table. Of course, while unlikely, another VRef+-- may have since replaced the existing one. +clearVRef :: VSpace -> Address -> TypeRep -> IO ()+clearVRef !vc !addr !ty = modifyMVarMasked_ (vcache_memory vc) $ \ m -> do+    evrefs' <- tryDelVREph addr ty (mem_evrefs m)+    cvrefs' <- tryDelVREph addr ty (mem_cvrefs m)+    let m' = m { mem_evrefs = evrefs', mem_cvrefs = cvrefs' }+    return $! m'++tryDelVREph :: Address -> TypeRep -> VREphMap -> IO VREphMap+tryDelVREph !addr !ty !em =+    case takeVREph addr ty em of+        Nothing -> return em+        Just (VREph { vreph_cache = wk }, em') ->+            Weak.deRefWeak wk >>= \ mbc ->+            if isJust mbc then return em  -- replaced (improbable; race condition)+                          else return em' -- removed++-- This is certainly an unsafe operation in general, but we have+-- already validated the TypeRep matches.+_getVREphCache :: VREph -> IO (Maybe (IORef (Cache a)))+_getVREphCache = Weak.deRefWeak . _u where+    _u :: VREph -> Weak (IORef (Cache a))+    _u (VREph { vreph_cache = w }) = _c w +    _c :: Weak (IORef (Cache b)) -> Weak (IORef (Cache a))+    _c = unsafeCoerce+{-# INLINE _getVREphCache #-}++mbrun :: (Applicative m) => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)+mbrun = maybe (pure Nothing) +{-# INLINE mbrun #-}+ +-- | Obtain a PVar given an address. PVar will lazily load when read.+-- This operation does not try to read the database. It may fail if+-- the requested address has already been loaded with another type.+addr2pvar :: (VCacheable a) => VSpace -> Address -> IO (PVar a)+addr2pvar !vc !addr = +    assert (isPVarAddr addr) $ +    modifyMVarMasked (vcache_memory vc) $ +    addr2pvar' vc addr+{-# INLINE addr2pvar #-}++addr2pvar' :: (VCacheable a) => VSpace -> Address -> Memory -> IO (Memory, PVar a) +addr2pvar' !vc !addr m = _addr2pvar undefined vc addr m+{-# INLINE addr2pvar' #-}++_addr2pvar :: (VCacheable a) => a -> VSpace -> Address -> Memory -> IO (Memory, PVar a)+_addr2pvar _dummy !vc !addr m = do+    let ty = typeOf _dummy+    mbVar <- loadPVarTVar addr ty (mem_pvars m)+    case mbVar of+        Just var -> return (m, PVar addr var vc ty put)+        Nothing -> do+            lzv <- unsafeInterleaveIO $ RDV . fst <$> readAddrIO vc addr get+            var <- newTVarIO lzv+            e <- mkPVEph vc addr var ty+            let m' = m { mem_pvars = addPVEph e (mem_pvars m) }+            m' `seq` return (m', PVar addr var vc ty put)+{-# NOINLINE _addr2pvar #-}++mkPVEph :: VSpace -> Address -> TVar (RDV a) -> TypeRep -> IO PVEph+mkPVEph !vc !addr !tvar !ty = +    mkWeakTVar tvar (clearPVar vc addr) >>= \ wkTVar ->+    return $! PVEph addr ty wkTVar+{-# INLINE mkPVEph #-}++loadPVarTVar :: Address -> TypeRep -> PVEphMap -> IO (Maybe (TVar (RDV a)))+loadPVarTVar !addr !ty !mpv =+    case Map.lookup addr mpv of+        Nothing -> return Nothing+        Just pve -> do+            let tye = pveph_type pve +            unless (ty == tye) (fail $ eTypeMismatch addr ty tye)+            _getPVEphTVar pve++eTypeMismatch :: Address -> TypeRep -> TypeRep -> String+eTypeMismatch addr tyNew tyOld = +    showString "PVar user error: address " . shows addr .+    showString " type mismatch on load. " .+    showString " Existing: " . shows tyOld .+    showString " Expecting: " . shows tyNew $ ""++-- Clear a PVar from the ephemeron map.+clearPVar :: VSpace -> Address -> IO ()+clearPVar !vc !addr = modifyMVarMasked_ (vcache_memory vc) $ \ m -> do+    pvars' <- tryDelPVEph addr (mem_pvars m)+    let m' = m { mem_pvars = pvars' }+    return $! m'++tryDelPVEph :: Address -> PVEphMap -> IO PVEphMap+tryDelPVEph !addr !mpv =+    case Map.lookup addr mpv of+        Nothing -> return mpv+        Just (PVEph { pveph_data = wk }) ->+            Weak.deRefWeak wk >>= \ mbd ->+            if isJust mbd then return mpv else+            return $! Map.delete addr mpv++-- unsafe: get data, assuming that type already matches.+_getPVEphTVar :: PVEph -> IO (Maybe (TVar (RDV a)))+_getPVEphTVar = Weak.deRefWeak . _u where+    _u :: PVEph -> Weak (TVar (RDV a))+    _u (PVEph { pveph_data = w }) = _c w+    _c :: Weak (TVar (RDV b)) -> Weak (TVar (RDV a))+    _c = unsafeCoerce+{-# INLINE _getPVEphTVar #-}++-- | Construct a new VRef and initialize cache with given value.+-- If cache exists, will touch existing cache as if dereferenced.+newVRefIO :: (VCacheable a) => VSpace -> a -> CacheMode -> IO (VRef a)+newVRefIO vc v cm = +    runVPutIO vc (put v) >>= \ ((), _data, _deps) ->+    allocVRefIO vc _data _deps >>= \ vref ->+    join $ atomicModifyIORef (vref_cache vref) $ \ c -> case c of+        Cached r bf ->+            let bf' = touchCache cm bf in+            let c' = Cached r bf' in+            (c', c' `seq` return vref)+        NotCached ->+            let w = cacheWeight (BS.length _data) (L.length _deps) in+            let c' = mkVRefCache v w cm in+            let op = initVRefCache vref >> return vref in+            (c', c' `seq` op)+{-# NOINLINE newVRefIO #-}++-- I've split the mem_vrefs into two partitions, evrefs and cvrefs.+-- This shifts allows the cache manager to focus on just the cvrefs+-- partition, which will typically be much smaller than evrefs.+-- +-- After a value is first cached, whichever thread was responsible must+-- move the content from the mem_evrefs partition into mem_cvrefs. The+-- cache manager may later move it back and then clear the cache.+--+-- Cached values may be held temporarily by mem_evrefs, i.e. prior to+-- 'init' or just before the cache is cleared. But NotCached VRefs +-- should never be held by mem_cvrefs. +initVRefCache :: VRef a -> IO ()+initVRefCache !vref = +    let vc = vref_space vref in+    let addr = vref_addr vref in+    let ty = vref_type vref in+    modifyMVarMasked_ (vcache_memory vc) $ \ m -> +    case takeVREph addr ty (mem_evrefs m) of+        Nothing -> fail $ show vref ++ " expected in mem_evrefs partition!"+        Just (e, evrefs') ->+            let cvrefs' = addVREph e (mem_cvrefs m) in+            let m' = m { mem_evrefs = evrefs', mem_cvrefs = cvrefs' } in+            return $! m'+{-# NOINLINE initVRefCache #-}++-- | Construct a new VRef without initializing the cache.+newVRefIO' :: (VCacheable a) => VSpace -> a -> IO (VRef a) +newVRefIO' !vc v =+    runVPutIO vc (put v) >>= \ ((), _data, _deps) ->+    allocVRefIO vc _data _deps +{-# INLINE newVRefIO' #-}++-- | Allocate a VRef given data and dependencies.+--+-- We'll try to find an existing match in the database, then from the+-- recent allocations list, skipping addresses that have recently been+-- GC'd (to account for readers running a little behind the writer).+--+-- If a match is discovered, we'll use the existing address. Otherwise,+-- we'll allocate a new address and leave it to the background writer thread.+--+allocVRefIO :: (VCacheable a) => VSpace -> ByteString -> [PutChild] -> IO (VRef a)+allocVRefIO !vc !_data !_deps = +    let _name = hash _data in+    withByteStringVal _name $ \ vName ->+    withByteStringVal _data $ \ vData ->+    withRdOnlyTxn vc $ \ txn ->+    listDups' txn (vcache_db_caddrs vc) vName >>= \ caddrs ->+    seek (candidateVRefInDB vc txn vData) caddrs >>= \ mbVRef ->+    case mbVRef of+        Just !vref -> return vref -- found matching VRef in database+        Nothing -> modifyMVarMasked (vcache_memory vc) $ \ m -> +            let okAddr addr = isVRefAddr addr && not (recentGC (mem_gc m) addr) in+            let match an = okAddr (alloc_addr an) && (_data == (alloc_data an)) in+            let ff frm = Map.lookup _name (alloc_seek frm) >>= L.find match in+            case allocFrameSearch ff (mem_alloc m) of+                Just an -> addr2vref' vc (alloc_addr an) m -- found among recent allocations+                Nothing -> do -- allocate a new VRef address+                    let ac = mem_alloc m+                    let addr = alloc_new_addr ac+                    let an = Allocation { alloc_name = _name, alloc_data = _data+                                        , alloc_deps = _deps, alloc_addr = addr }+                    let frm' = addToFrame an (alloc_frm_next ac) +                    let ac' = ac { alloc_new_addr = 2 + addr, alloc_frm_next = frm' }+                    let m' = m { mem_alloc = ac' }+                    signalAlloc vc+                    addr2vref' vc addr m'+{-# NOINLINE allocVRefIO #-}++-- list all values associated with a given key+listDups' :: MDB_txn -> MDB_dbi' -> MDB_val -> IO [MDB_val]+listDups' txn dbi vKey = +    alloca $ \ pKey ->+    alloca $ \ pVal ->+    withCursor' txn dbi $ \ crs -> do+    let loop l b = +            if not b then return l else+            peek pVal >>= \ v ->+            mdb_cursor_get' MDB_NEXT_DUP crs pKey pVal >>= \ b' ->+            loop (v:l) b'+    poke pKey vKey+    b0 <- mdb_cursor_get' MDB_SET_KEY crs pKey pVal+    loop [] b0++withCursor' :: MDB_txn -> MDB_dbi' -> (MDB_cursor' -> IO a) -> IO a+withCursor' txn dbi = bracket g d where+    g = mdb_cursor_open' txn dbi+    d = mdb_cursor_close'+{-# INLINABLE withCursor' #-}++-- seek an exact match in the database. This will return Nothing in+-- one of these conditions:+--   (a) the candidate is not an exact match for the data+--   (b) the candidate has recently been GC'd from memory+-- Otherwise will return the necessary VRef.+candidateVRefInDB :: (VCacheable a) => VSpace -> MDB_txn -> MDB_val -> MDB_val -> IO (Maybe (VRef a))+candidateVRefInDB vc txn vData vCandidateAddr = do+    mbR <- mdb_get' txn (vcache_db_memory vc) vCandidateAddr+    case mbR of+        Nothing -> -- inconsistent hashmap and memory; this should never happen+            peekAddr vCandidateAddr >>= \ addr ->+            fail $ "VCache bug: undefined address " ++ show addr ++ " in hashmap" +        Just vData' ->+            let bSameSize = mv_size vData == mv_size vData' in+            if not bSameSize then return Nothing else+            c_memcmp (mv_data vData) (mv_data vData') (mv_size vData) >>= \ o ->+            if (0 /= o) then return Nothing else+            peekAddr vCandidateAddr >>= \ addr -> -- exact match! But maybe GC'd.+            modifyMVarMasked (vcache_memory vc) $ \ m ->+                if (recentGC (mem_gc m) addr) then return (m, Nothing) else+                addr2vref' vc addr m >>= \ (m', vref) ->+                return (m', Just vref)+++-- add annotation to frame without seek+addToFrame :: Allocation -> AllocFrame -> AllocFrame+addToFrame an frm + | BS.null (alloc_name an) = -- anonymous PVars +    assert (isPVarAddr (alloc_addr an)) $+    let list' = Map.insert (alloc_addr an) an (alloc_list frm) in+    frm { alloc_list = list' }+ | otherwise = -- root PVars or hashed VRefs +    let list' = Map.insert (alloc_addr an) an (alloc_list frm) in+    let add_an = Just . (an:) . maybe [] id in+    let seek' = Map.alter add_an (alloc_name an) (alloc_seek frm) in+    frm { alloc_list = list', alloc_seek = seek' }++peekAddr :: MDB_val -> IO Address+peekAddr v =+    let expectedSize = fromIntegral (sizeOf (undefined :: Address)) in+    let bBadSize = expectedSize /= mv_size v in+    if bBadSize then fail "VCache bug: badly formed address" else+    peekAligned (castPtr (mv_data v))+{-# INLINABLE peekAddr #-}++   +seek :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+seek _ [] = return Nothing+seek f (x:xs) = f x >>= continue where+    continue Nothing = seek f xs+    continue r@(Just _) = return r +++++-- Intermediate data to allocate a new PVar. We don't know the+-- address yet, but we do know every other relevant aspect of+-- this PVar.+data AllocPVar a = AllocPVar+    { alloc_pvar_name :: !ByteString+    , alloc_pvar_data :: !ByteString+    , alloc_pvar_deps :: ![PutChild]+    , alloc_pvar_tvar :: !(TVar (RDV a))+    }++-- | Create a new, anonymous PVar as part of an active transaction.+-- Contents of the new PVar are not serialized unless the transaction+-- commits (though a placeholder is still allocated). +newPVar :: (VCacheable a) => a -> VTx (PVar a)+newPVar x = do+    vc <- getVTxSpace+    pvar <- liftSTM $ unsafeIOToSTM $ +                newTVarIO (RDV x) >>= \ tvar ->+                modifyMVarMasked (vcache_memory vc) $+                allocPVar vc $ allocPlaceHolder BS.empty tvar+    markForWrite pvar x+    return pvar++allocPlaceHolder :: ByteString -> TVar (RDV a) -> AllocPVar a+allocPlaceHolder _name tvar = AllocPVar+    { alloc_pvar_name = _name+    , alloc_pvar_data = BS.singleton 0+    , alloc_pvar_deps = []+    , alloc_pvar_tvar = tvar +    }++-- | Create a new, anonymous PVar via the IO monad. This is similar+-- to `newTVarIO`, but not as well motivated: global PVars should+-- almost certainly be constructed as named, persistent roots. +-- +newPVarIO :: (VCacheable a) => VSpace -> a -> IO (PVar a)+newPVarIO vc x = do+    apv <- preAllocPVarIO vc BS.empty x+    pvar <- modifyMVarMasked (vcache_memory vc) $ allocPVar vc apv+    signalAlloc vc+    return pvar++preAllocPVarIO :: (VCacheable a) => VSpace -> ByteString -> a -> IO (AllocPVar a)+preAllocPVarIO vc _name x = do+    tvar <- newTVarIO (RDV x)+    ((), _data, _deps) <- runVPutIO vc (put x)+    return $! AllocPVar+        { alloc_pvar_name = _name+        , alloc_pvar_data = _data+        , alloc_pvar_deps = _deps+        , alloc_pvar_tvar = tvar+        }++-- | Create an array of PVars with a given set of initial values. This+-- is equivalent to `mapM newPVar`, but guarantees adjacent addresses+-- in the persistence layer. This is mostly useful when working with +-- large arrays, to simplify reasoning about paging performance.+newPVars :: (VCacheable a) => [a] -> VTx [PVar a]+newPVars [] = return []+newPVars xs = do+    vc <- getVTxSpace +    pvars <- liftSTM $ unsafeIOToSTM $ do+        tvars <- mapM (newTVarIO . RDV) xs+        let apvs = fmap (allocPlaceHolder BS.empty) tvars +        allocPVars vc apvs+    sequence_ (L.zipWith markForWrite pvars xs)+    return pvars++-- | Create an array of adjacent PVars via the IO monad. +newPVarsIO :: (VCacheable a) => VSpace -> [a] -> IO [PVar a]+newPVarsIO _ [] = return []+newPVarsIO vc xs = do+    apvs <- mapM (preAllocPVarIO vc BS.empty) xs+    pvars <- allocPVars vc apvs+    signalAlloc vc+    return pvars++-- add a list of PVars to memory, acquiring addresses as we go.+allocPVars :: (VCacheable a) => VSpace -> [AllocPVar a] -> IO [PVar a]+allocPVars vc xs = +    let step (m, vars) apv =+            allocPVar vc apv m >>= \ (m', pvar) ->+            return (m', pvar:vars)+    in+    modifyMVar (vcache_memory vc) $ \ m -> do+    (!m', lReversedPVars) <- foldM step (m,[]) xs+    return (m', L.reverse lReversedPVars)++allocPVar :: (VCacheable a) => VSpace -> AllocPVar a -> Memory -> IO (Memory, PVar a)+allocPVar = _allocPVar undefined+{-# INLINE allocPVar #-}++_allocPVar :: (VCacheable a) => a -> VSpace -> AllocPVar a -> Memory -> IO (Memory, PVar a)+_allocPVar _dummy !vc !apv !m = do+    let ty = typeOf _dummy+    let tvar = alloc_pvar_tvar apv+    let ac = mem_alloc m+    let pv_addr = 1 + (alloc_new_addr ac)+    let pvar = PVar pv_addr tvar vc ty put+    pveph <- mkPVEph vc pv_addr tvar ty+    let an  = Allocation+            { alloc_name = alloc_pvar_name apv+            , alloc_data = alloc_pvar_data apv+            , alloc_addr = pv_addr+            , alloc_deps = alloc_pvar_deps apv+            }+    let frm' = addToFrame an (alloc_frm_next ac)+    let addr' = 2 + alloc_new_addr ac+    let ac' = ac { alloc_new_addr = addr', alloc_frm_next = frm' }+    let pvars' = addPVEph pveph (mem_pvars m)+    let m' = m { mem_pvars = pvars', mem_alloc = ac' }+    return (m', pvar)+{-# NOINLINE _allocPVar #-}++-- | Global, persistent variables may be loaded by name. The name here+-- is prefixed by vcacheSubdir to control namespace collisions between+-- software components. These named variables are roots for GC purposes,+-- and will not be deleted.+--+-- Conceptually, the root PVar has always been there. Loading a root+-- is thus a pure computation. At the very least, it's an idempotent+-- operation. If the PVar exists, its value is lazily read from the+-- persistence layer. Otherwise, the given initial value is stored.+-- To reset a root PVar, simply write before reading.+-- +-- The recommended practice for roots is to use only a few of them for+-- each persistent software component (i.e. each plugin, WAI app, etc.)+-- similarly to how a module might use just a few global variables. If+-- you need a dynamic set of variables, such as one per client, model+-- that explicitly using anonymous PVars. +--+loadRootPVar :: (VCacheable a) => VCache -> ByteString -> a -> PVar a+loadRootPVar vc name ini = unsafePerformIO (loadRootPVarIO vc name ini)+{-# INLINE loadRootPVar #-}++-- | Load a root PVar in the IO monad. This is convenient to control +-- where errors are detected or when initialization is performed.+-- See loadRootPVar.+loadRootPVarIO :: (VCacheable a) => VCache -> ByteString -> a -> IO (PVar a)+loadRootPVarIO vc !name ini =+    case vcacheSubdirM name vc of+        Just (VCache vs path) -> _loadRootPVarIO vs path ini+        Nothing ->+            let path = vcache_path vc `BS.append` name in+            fail $  "VCache: root PVar path too long: " ++ show path++_loadRootPVarIO :: (VCacheable a) => VSpace -> ByteString -> a -> IO (PVar a)+_loadRootPVarIO vc !_name ini = withRdOnlyTxn vc $ \ txn ->+    withByteStringVal _name $ \ rootKey ->+    mdb_get' txn (vcache_db_vroots vc) rootKey >>= \ mbRoot ->+    case mbRoot of+        Just val -> peekAddr val >>= addr2pvar vc -- found root in database+        Nothing -> -- usually allocate new PVar, possibly find in recent allocations+            preAllocPVarIO vc _name ini >>= \ apv -> -- for common case...+            modifyMVarMasked (vcache_memory vc) $ \ m ->+                let match an = isPVarAddr (alloc_addr an) in+                let ff frm = Map.lookup _name (alloc_seek frm) >>= L.find match in+                case allocFrameSearch ff (mem_alloc m) of+                    Just an -> addr2pvar' vc (alloc_addr an) m -- recent allocation+                    Nothing -> signalAlloc vc >> allocPVar vc apv m -- new root PVar+{-# NOINLINE _loadRootPVarIO #-}+ +-- report allocation to the writer thread+signalAlloc :: VSpace -> IO ()+signalAlloc vc = void $ tryPutMVar (vcache_signal vc) () ++foreign import ccall unsafe "string.h memcmp" c_memcmp+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt+

@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns #-}+-- | Limited cache control.+module Database.VCache.Cache+    ( setVRefsCacheLimit+    , clearVRefsCache+    , clearVRefCache+    ) where++import Data.IORef+import Control.Concurrent.MVar+import qualified Data.Map.Strict as Map+import qualified System.Mem.Weak as Weak+import Database.VCache.Types++-- | VCache uses simple heuristics to decide which VRef contents to+-- hold in memory. One heuristic is a target cache size. Developers+-- may tune this to influence how many VRefs are kept in memory. +--+-- The value is specified in bytes, and the default is ten megabytes.+--+-- VCache size estimates are imprecise, converging on approximate +-- size, albeit not accounting for memory amplification (e.g. from a+-- compact UTF-8 string to Haskell's representation for [Char]). The+-- limit given here is soft, influencing how aggressively content is+-- removed from cache - i.e. there is no hard limit on content held+-- by the cache. Estimated cache size is observable via vcacheStats.+--+-- If developers need precise control over caching, they should use+-- normal means to reason about GC of values in Haskell (i.e. VRef is+-- cleared from cache upon GC). Or use vref' and deref' to avoid +-- caching and use VCache as a simple serialization layer.+-- +setVRefsCacheLimit :: VSpace -> Int -> IO ()+setVRefsCacheLimit vc !n = writeIORef (vcache_climit vc) n+{-# INLINE setVRefsCacheLimit #-}++-- | clearVRefsCache will iterate over cached VRefs in Haskell memory +-- at the time of the call, clearing the cache for each of them. This +-- operation isn't recommended for common use. It is rather hostile to+-- independent libraries working with VCache. But this function may +-- find some use for benchmarks or staged applications.+clearVRefsCache :: VSpace -> IO ()+clearVRefsCache vc = do +    -- we must hold lock for long enough to move contents to mem_evrefs+    ephMap <- modifyMVarMasked (vcache_memory vc) $ \ m -> do+        let evrefs' = Map.unionWith (Map.union) (mem_cvrefs m) (mem_evrefs m) +        let m' = m { mem_cvrefs = Map.empty, mem_evrefs = evrefs' }+        m' `seq` return (m', mem_cvrefs m)+    mapM_ (mapM_ clearVREphCache . Map.elems) (Map.elems ephMap)+{-# NOINLINE clearVRefsCache #-}++clearVREphCache :: VREph -> IO ()+clearVREphCache (VREph { vreph_cache = wc }) =   +    Weak.deRefWeak wc >>= \ mbCache ->+    case mbCache of+        Nothing -> return ()+        Just cache -> writeIORef cache NotCached+++-- | Immediately clear the cache associated with a VRef, allowing +-- any contained data to be GC'd. Normally, VRef cached values are+-- cleared either by a background thread or when the VRef itself+-- is garbage collected from Haskell memory. But sometimes the+-- programmer knows best.+clearVRefCache :: VRef a -> IO ()+clearVRefCache v = do+    let vc = vref_space v +    modifyMVarMasked_ (vcache_memory vc) $ \ m -> do+        case takeVREph (vref_addr v) (vref_type v) (mem_cvrefs m) of+            Nothing -> return m -- was not cached+            Just (e, cvrefs') -> do+                let evrefs' = addVREph e (mem_evrefs m)+                let m' = m { mem_cvrefs = cvrefs', mem_evrefs = evrefs' }+                return $! m'+    writeIORef (vref_cache v) NotCached+{-# NOINLINE clearVRefCache #-}++

@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns #-}+-- This module manages the ephemeron tables and VRef caches.+-- +-- In addition, this thread will signal the writer when there seems+-- to be some GC work to perform.  +--+-- DESIGN THOUGHTS:+--+-- The original implementation was inefficient, touching far too many+-- VRefs in each pass. It didn't scale nicely.+--+-- I've redesigned to partition VRefs so I can easily find just those+-- that are cached. And the cleanup function now touches only those in+-- cache. Clearing GC'd content is now handled by the System.Mem.Weak +-- finalizers. Size estimates must be probabilistic, to avoid a global+-- pass to compute sizes.+--+-- At this point, the clean function only touches elements that are +-- certainly cached, and which it plans to remove from cache. The +-- cleanup function is based on exponential decay, i.e. we try to+-- remove X% of the cache in each round. Though X may vary based on+-- whether we are over or under our heuristic cache limit.+--+-- Originally, I had some sophisticated usage tracking. I could move+-- some of this to the touchCache operation, but for now I'm just+-- going to assume that CacheMode alone is sufficient in most cases+-- due to how it resets on each deref.+--+module Database.VCache.Clean+    ( cleanStep+    ) where++import Control.Monad+import Control.Applicative+import Control.Concurrent+import Data.Bits+import qualified Data.Traversable as TR+import qualified Data.Map.Strict as Map+import Data.IORef+import qualified System.Mem.Weak as Weak+import qualified System.Random as Random++import Database.LMDB.Raw+import Database.VCache.Types++-- | Cache cleanup, and signal writer for old content.+cleanStep :: VSpace -> IO ()+cleanStep vc = do+    bsig <- shouldSignalWriter vc+    when bsig (signalWriter vc)++    wtgt <- readIORef (vcache_climit vc)+    w0 <- estCacheSize vc+    let hitRate = +            if ((100 * w0) < ( 80 * wtgt)) then 0.00 else+            if ((100 * w0) < (100 * wtgt)) then 0.01 else+            if ((100 * w0) < (130 * wtgt)) then 0.02 else+            if ((100 * w0) < (170 * wtgt)) then 0.03 else+            if ((100 * w0) < (220 * wtgt)) then 0.04 else +            if ((100 * w0) < (280 * wtgt)) then 0.05 else+            0.06+    xcln vc hitRate+    updateCacheSizeEst vc+    wf <- estCacheSize vc++    let bSatisfied = (max w0 wf) < wtgt+    let dtSleep = if bSatisfied then 295000 else 95000 +    usleep dtSleep -- ~10Hz, slower when steady++-- sleep for a number of microseconds+usleep :: Int -> IO ()+usleep = threadDelay+{-# INLINE usleep #-}++-- For now, I'm choosing to use sqrt( avgSquare ) because it is +-- weighted in favor of larger values, which (conversely) we're+-- less likely to find when randomly sampling a collection with +-- just a few large values and lots of small ones. +--+estCacheSize :: VSpace -> IO Int+estCacheSize vc = do+    csze <- readIORef (vcache_csize vc)+    let avgAddr = sqrt (csze_addr_sqsz csze) +    ctAddrs <- fromIntegral <$> readCacheAddrCt vc+    return $! ceiling $ avgAddr * ctAddrs++readCacheAddrCt :: VSpace -> IO Int+readCacheAddrCt vc = do+    m <- readMVar (vcache_memory vc)+    return $! Map.size (mem_cvrefs m)++-- sample the cache at a few random addresses, use this to update the+-- cache size by a small factor. Over the course of many seconds, the+-- estimated average size per address should approach the actual size+-- assuming the average itself is stable. Even if average size isn't+-- stable, this is good enough to help guide the cache manager.+--+-- The assumption here is that the cvrefs map is usually large. If it+-- is small, we'll still use the same algorithm, even if it's a bit +-- redundant, to simplify reasoning and testing. A constant number of+-- samples are taken in each round. Probabilistically+updateCacheSizeEst :: VSpace -> IO ()+updateCacheSizeEst vc =+    readMVar (vcache_memory vc) >>= \ m ->+    let cvrefs = mem_cvrefs m in+    if Map.null cvrefs then return () else+    let nextIx = Random.randomR (0, Map.size cvrefs - 1) in+    let loop !n !r !sz !sqsz = +            if (0 == n) then return (sz,sqsz) else+            let (ix,r') = nextIx r in+            let (_, tym) = Map.elemAt ix cvrefs in+            let (_, e) = Map.findMin tym in -- safe; address elements non-empty+            readVREphSize e >>= \ esz ->+            let addrsz = fromIntegral $ esz * Map.size tym in+            let sz' = sz + addrsz in+            let sqsz' = sqsz + (addrsz * addrsz) in+            loop (n-1) r' sz' sqsz'+    in+    let nSamples = 15 :: Int in+    Random.newStdGen >>= \ r ->+    loop nSamples r 0 0 >>= \ (totalSize, totalSqSize) ->+    let sampleAvg = totalSize / fromIntegral nSamples in+    let sampleAvgSq = totalSqSize / fromIntegral nSamples in+    readIORef (vcache_csize vc) >>= \ (CacheSizeEst oldAvg oldAvgSq) ->+    let alpha = 0.015 :: Double in+    let newAvg = alpha * sampleAvg + ((1.0 - alpha) * oldAvg) in+    let newAvgSq = alpha * sampleAvgSq + ((1.0 - alpha) * oldAvgSq) in+    writeIORef (vcache_csize vc) $! (CacheSizeEst newAvg newAvgSq)++readVREphSize :: VREph -> IO Int+readVREphSize (VREph { vreph_cache = wk }) =+    Weak.deRefWeak wk >>= \ mbc -> case mbc of +        Nothing -> return 2048 -- GC'd recently; high estimate+        Just cache -> readIORef cache >>= \ c -> case c of+            NotCached -> +                let eMsg = "VCache bug: NotCached element found in mem_cvrefs" in+                fail eMsg+            Cached _ bf ->+                let lgSz = 6 + fromIntegral (0x1f .&. bf) in+                return $! 1 `shiftL` lgSz++-- | exponential decay based cleanup. In this case, we attack a+-- random fraction of the cached addresses. Each attack reduces+-- the CacheMode of cached elements. If the CacheMode is zero, the+-- element is removed from the database. Active contents have their+-- CacheMode reset on each use, and cleanup stops when estimated +-- size is good. +xcln :: VSpace -> Double -> IO ()+xcln !vc !hr = do+    ct <- readCacheAddrCt vc+    let hct = ceiling $ hr * fromIntegral ct +    r <- Random.newStdGen+    xclnLoop vc hct r++xclnLoop :: VSpace -> Int -> Random.StdGen -> IO ()+xclnLoop !vc !n !r =+    if (n < 1) then return () else+    xclnStrike vc r >>= xclnLoop vc (n-1)++xclnStrike :: VSpace -> Random.StdGen -> IO Random.StdGen+xclnStrike !vc !r = modifyMVarMasked (vcache_memory vc) $ \ m ->+    if Map.null (mem_cvrefs m) then return (m,r) else do+    let cvrefs = mem_cvrefs m+    let evrefs = mem_evrefs m+    let (ix,r') = Random.randomR (0, Map.size cvrefs - 1) r+    let (addr, tym) = Map.elemAt ix cvrefs +    (tymc, tyme) <- Map.mapEither id <$> TR.traverse strikeVREph tym+    let cvrefs' = if Map.null tymc then Map.delete addr cvrefs else+                  if Map.null tyme then cvrefs else+                  Map.insert addr tymc cvrefs+    let evrefs' = if Map.null tyme then evrefs else+                  Map.insertWith (Map.union) addr tyme evrefs+    let m' = m { mem_cvrefs = cvrefs', mem_evrefs = evrefs' }+    return (m', m' `seq` r')++-- strikeVREph will reduce the CacheMode for a cached element or+-- remove it from the cache (in right) for CacheMode0.+strikeVREph :: VREph -> IO (Either VREph VREph)+strikeVREph vreph@(VREph { vreph_cache = wk }) =+    Weak.deRefWeak wk >>= \ mbCache -> case mbCache of+        Nothing -> return (Right vreph) -- +        Just cache -> atomicModifyIORef cache $ \ c -> case c of+            Cached r bf | (0 /= bf .&. 0x60) -> +                let bf' = (0x80 .|. (bf - 0x20)) in+                let c' = Cached r bf' in+                (c', c' `seq` (Left vreph))+            _ -> (NotCached, Right vreph)++-- If the writer has obvious work it could be doing, signal it. This+-- won't significantly affect a busy writer, but an idle writer may+-- require a kick in the pants to remove content from the allocations+-- list or clear old zeroes.+shouldSignalWriter :: VSpace -> IO Bool+shouldSignalWriter vc = +    readMVar (vcache_memory vc) >>= \ m ->+    let bHoldingAllocs = not (emptyAllocation (mem_alloc m)) in+    if bHoldingAllocs then return True else+    readZeroesCt vc >>= \ ctZeroes ->+    let ctEphAddrs = Map.size (mem_cvrefs m) + Map.size (mem_evrefs m) + Map.size (mem_pvars m) in+    if (ctEphAddrs < ctZeroes) then return True else+    return False++readZeroesCt :: VSpace -> IO Int+readZeroesCt vc = withRdOnlyTxn vc $ \ txn ->+    mdb_stat' txn (vcache_db_refct0 vc) >>= \ stat ->+    return $! fromIntegral (ms_entries stat)++emptyAllocation :: Allocator -> Bool+emptyAllocation ac = fn n && fn c && fn p where+    n = alloc_frm_next ac+    c = alloc_frm_curr ac+    p = alloc_frm_prev ac+    fn = Map.null . alloc_list++signalWriter :: VSpace -> IO ()+signalWriter vc = void $ tryPutMVar (vcache_signal vc) ()

@@ -0,0 +1,23 @@++-- This is the hash function for content addressing.+module Database.VCache.Hash+    ( hash+    , hashVal+    ) where++import qualified Data.Digest.Murmur3 as M3+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import Foreign.ForeignPtr++import Database.LMDB.Raw (MDB_val(..))++hash :: ByteString -> ByteString+hash = BS.take 8 . M3.asByteString . M3.hash++hashVal :: MDB_val -> IO ByteString+hashVal mv = do+    fp <- newForeignPtr_ (mv_data mv) -- no finalizer+    let bs = BSI.PS fp 0 (fromIntegral (mv_size mv))+    return $! hash bs

@@ -0,0 +1,246 @@+module Database.VCache.Open+    ( openVCache+    ) where++import Control.Monad+import Control.Exception+import System.FileLock (FileLock)+import qualified System.FileLock as FileLock+import qualified System.EasyFile as EasyFile+import qualified System.IO.Error as IOE+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Ptr++import Data.Bits+import Data.IORef+import Data.Maybe+import qualified Data.Map.Strict as Map+import qualified Data.ByteString as BS+import qualified Data.List as L+import Control.Concurrent.MVar+import Control.Concurrent.STM.TVar+import Control.Concurrent++import qualified System.IO as Sys+import qualified System.Exit as Sys++import Database.LMDB.Raw+import Database.VCache.Types +import Database.VCache.RWLock+import Database.VCache.Aligned+import Database.VCache.Write+import Database.VCache.Clean ++++-- | Open a VCache with a given database file. +--+-- In most cases, a Haskell process should open VCache in the Main+-- module then pass it as an argument to the different libraries,+-- frameworks, plugins, and other software components that require+-- persistent storage. Use vcacheSubdir to progect against namespace+-- collisions. +--+-- When opening VCache, developers decide the maximum size and the file+-- name. For example:+--+-- > vc <- openVCache 100 "db"+--+-- This would open a VCache whose file-size limit is 100 megabytes, +-- with the name "db", plus an additional "db-lock" lockfile. An +-- exception will be raised if these files cannot be created, locked,+-- or opened. The size limit is passed to LMDB and is separate from+-- setVRefsCacheSize. +--+-- Once opened, VCache typically remains open until process halt. +-- If errors are detected, e.g. due to writing an undefined value+-- to a PVar or running out of space, VCache will attempt to halt+-- the process.+--+openVCache :: Int -> FilePath -> IO VCache+openVCache nMB fp = do+    let (fdir,fn) = EasyFile.splitFileName fp+    let eBadFile = fp ++ " not recognized as a file name"+    when (L.null fn) (fail $ "openVCache: " ++ eBadFile)+    EasyFile.createDirectoryIfMissing True fdir+    let fpLock = fp ++ "-lock"+    let nBytes = (max 1 nMB) * 1024 * 1024+    mbLock <- FileLock.tryLockFile fpLock FileLock.Exclusive +    case mbLock of+        Nothing -> ioError $ IOE.mkIOError+            IOE.alreadyInUseErrorType+            "openVCache lockfile"+            Nothing (Just fpLock)+        Just fl -> openVC' nBytes fl fp +                    `onException` FileLock.unlockFile fl++vcFlags :: [MDB_EnvFlag] +vcFlags = [MDB_NOSUBDIR     -- open file name, not directory name+          ,MDB_NOLOCK       -- leave lock management to VCache+          ]++--+-- I'm providing a non-empty root bytestring. There are a few reasons+-- for this. LMDB doesn't support zero-sized keys. And the empty+-- bytestring will indicate anonymous PVars in the allocator. And if+-- I ever want PVar roots within VCache, I can use a different prefix.+--+-- The maximum path, including the PVar name, is 511 bytes. That is+-- enough for almost any use case, especially since roots should not+-- depend on domain data. Too large a path results in runtime error.+vcRootPath :: BS.ByteString+vcRootPath = BS.singleton 47++-- Default address for allocation. We start this high to help +-- regulate serialization sizes and simplify debugging.+vcAllocStart :: Address +vcAllocStart = 999999999++-- Default cache size is somewhat arbitrary. I've chosen to set it+-- to about ten megabytes (as documented in the Cache module). +vcDefaultCacheLimit :: Int+vcDefaultCacheLimit = 10 * 1000 * 1000 ++-- initial cache size+vcInitCacheSizeEst :: CacheSizeEst+vcInitCacheSizeEst = CacheSizeEst+    { csze_addr_size = sz -- err likely on high side to start+    , csze_addr_sqsz = (sz * sz)+    }+    where sz = 2048 -- err likely on high side to start++-- Checking for a `-threaded` runtime+threaded :: Bool+threaded = rtsSupportsBoundThreads++openVC' :: Int -> FileLock -> FilePath -> IO VCache+openVC' nBytes fl fp = do+    +    unless threaded (fail "VCache needs -threaded runtime")++    dbEnv <- mdb_env_create+    mdb_env_set_mapsize dbEnv nBytes+    mdb_env_set_maxdbs dbEnv 5+    mdb_env_open dbEnv fp vcFlags+    flip onException (mdb_env_close dbEnv) $ do++        -- initial transaction to grab database handles and init allocator+        txnInit <- mdb_txn_begin dbEnv Nothing False+        dbiMemory <- mdb_dbi_open' txnInit (Just "@") [MDB_CREATE, MDB_INTEGERKEY]+        dbiRoots  <- mdb_dbi_open' txnInit (Just "/") [MDB_CREATE]+        dbiHashes <- mdb_dbi_open' txnInit (Just "#") [MDB_CREATE, MDB_INTEGERKEY, MDB_DUPSORT, MDB_DUPFIXED, MDB_INTEGERDUP]+        dbiRefct  <- mdb_dbi_open' txnInit (Just "^") [MDB_CREATE, MDB_INTEGERKEY]+        dbiRefct0 <- mdb_dbi_open' txnInit (Just "%") [MDB_CREATE, MDB_INTEGERKEY]+        allocEnd <- findLastAddrAllocated txnInit dbiMemory+        mdb_txn_commit txnInit++        -- ephemeral resources+        let allocStart = nextAllocAddress allocEnd+        memory <- newMVar (initMemory allocStart)+        tvWrites <- newTVarIO (Writes Map.empty [])+        mvSignal <- newMVar ()+        cLimit <- newIORef vcDefaultCacheLimit+        cSize <- newIORef vcInitCacheSizeEst+        ctWrites <- newIORef $ WriteCt 0 0 0+        gcStart <- newIORef Nothing+        gcCount <- newIORef 0+        rwLock <- newRWLock++        -- finalizer, in unlikely event of closure+        _ <- mkWeakMVar mvSignal $ do+                mdb_env_close dbEnv+                FileLock.unlockFile fl++        let vc = VCache +                { vcache_path = vcRootPath+                , vcache_space = VSpace +                    { vcache_lockfile = fl+                    , vcache_db_env = dbEnv+                    , vcache_db_memory = dbiMemory+                    , vcache_db_vroots = dbiRoots+                    , vcache_db_caddrs = dbiHashes+                    , vcache_db_refcts = dbiRefct+                    , vcache_db_refct0 = dbiRefct0+                    , vcache_memory = memory+                    , vcache_signal = mvSignal+                    , vcache_writes = tvWrites+                    , vcache_rwlock = rwLock+                    , vcache_climit = cLimit+                    , vcache_csize = cSize+                    , vcache_signal_writes = updWriteCt ctWrites+                    , vcache_ct_writes = ctWrites+                    , vcache_alloc_init = allocStart+                    , vcache_gc_start = gcStart+                    , vcache_gc_count = gcCount+                    }+                }++        initVCacheThreads (vcache_space vc)+        return $! vc++-- our allocator should be set for the next *even* address.+nextAllocAddress :: Address -> Address+nextAllocAddress addr | (0 == (addr .&. 1)) = 2 + addr+                      | otherwise           = 1 + addr++-- Determine the last VCache VRef address allocated, based on the+-- actual database contents. If nothing is+findLastAddrAllocated :: MDB_txn -> MDB_dbi' -> IO Address+findLastAddrAllocated txn dbiMemory = alloca $ \ pKey ->+    mdb_cursor_open' txn dbiMemory >>= \ crs ->+    mdb_cursor_get' MDB_LAST crs pKey nullPtr >>= \ bFound ->+    mdb_cursor_close' crs >>+    if (not bFound) then return vcAllocStart else +    peek pKey >>= \ key -> +    let bBadSize = fromIntegral (sizeOf vcAllocStart) /= mv_size key in +    if bBadSize then fail "VCache memory table corrupted" else+    peekAligned (castPtr (mv_data key)) ++-- initialize memory based on initial allocation position+initMemory :: Address -> Memory+initMemory addr = m0 where+    af = AllocFrame Map.empty Map.empty addr+    ac = Allocator addr af af af+    gcf = GCFrame Map.empty+    gc = GC gcf gcf+    m0 = Memory Map.empty Map.empty Map.empty gc ac++-- Update write counts.+updWriteCt :: IORef WriteCt -> Writes -> IO ()+updWriteCt var w = modifyIORef' var $ \ wct ->+    let frmCt = 1 + wct_frames wct in+    let pvCt = wct_pvars wct + Map.size (write_data w) in+    let synCt = wct_sync wct + L.length (write_sync w) in+    WriteCt { wct_frames = frmCt, wct_pvars = pvCt, wct_sync = synCt }++-- | Create background threads needed by VCache.+initVCacheThreads :: VSpace -> IO ()+initVCacheThreads vc = begin where+    begin = do+        task (writeStep vc)+        task (cleanStep vc)+        return ()+    task step = void (forkIO (forever step `catch` onE))+    onE :: SomeException -> IO ()+    onE e | isBlockedOnMVar e = return () -- full GC of VCache+    onE e = do+        putErrLn "VCache background thread has failed."+        putErrLn (indent "  " (show e))+        putErrLn "Halting program."+        Sys.exitFailure++isBlockedOnMVar :: (Exception e) => e -> Bool+isBlockedOnMVar = isJust . test . toException where+    test :: SomeException -> Maybe BlockedIndefinitelyOnMVar+    test = fromException++putErrLn :: String -> IO ()+putErrLn = Sys.hPutStrLn Sys.stderr++indent :: String -> String -> String+indent ws = (ws ++) . indent' where+    indent' ('\n':s) = '\n' : ws ++ indent' s+    indent' (c:s) = c : indent' s+    indent' [] = []+

@@ -0,0 +1,112 @@++module Database.VCache.PVar+    ( PVar+    , newPVar+    , newPVars+    , newPVarIO+    , newPVarsIO+    , loadRootPVar+    , loadRootPVarIO+    , readPVar+    , readPVarIO+    , writePVar+    , modifyPVar+    , modifyPVar'+    , swapPVar+    , pvar_space+    , unsafePVarAddr+    , unsafePVarRefct+    ) where++import Control.Concurrent.STM++import Database.VCache.Types+import Database.VCache.Alloc ( newPVar, newPVars, newPVarIO, newPVarsIO+                             , loadRootPVar, loadRootPVarIO)+import Database.VCache.Read (readRefctIO)++-- | Read a PVar as part of a transaction.+readPVar :: PVar a -> VTx a+readPVar pvar = +    getVTxSpace >>= \ space ->+    if (space /= pvar_space pvar) then fail eBadSpace else+    liftSTM $ readTVar (pvar_data pvar) >>= \ rdv ->+              case rdv of { (RDV v) -> return v }+{-# INLINABLE readPVar #-}++-- Note that readPVar and readPVarIO must be strict in RDV in order to force+-- the initial, lazy read from the database. This is the only reason for RDV.+-- Without forcing here, a lazy read might return a value from an update.++-- | Read a PVar in the IO monad. +--+-- This is more efficient than a full transaction. It simply peeks at+-- the underlying TVar with readTVarIO. Durability of the value read+-- is not guaranteed. +readPVarIO :: PVar a -> IO a+readPVarIO pv = +    readTVarIO (pvar_data pv) >>= \ rdv ->+    case rdv of { (RDV v) -> return v }+{-# INLINE readPVarIO #-}++eBadSpace :: String+eBadSpace = "VTx: mismatch between VTx VSpace and PVar VSpace"++-- | Write a PVar as part of a transaction.+writePVar :: PVar a -> a -> VTx ()+writePVar pvar v = +    getVTxSpace >>= \ space ->+    if (space /= pvar_space pvar) then fail eBadSpace else+    markForWrite pvar v >>+    liftSTM (writeTVar (pvar_data pvar) (RDV v))+{-# INLINABLE writePVar #-}+++-- | Modify a PVar. +modifyPVar :: PVar a -> (a -> a) -> VTx ()+modifyPVar var f = do+    x <- readPVar var+    writePVar var (f x)+{-# INLINE modifyPVar #-}++-- | Modify a PVar, strictly.+modifyPVar' :: PVar a -> (a -> a) -> VTx ()+modifyPVar' var f = do+    x <- readPVar var+    writePVar var $! f x+{-# INLINE modifyPVar' #-}++-- | Swap contents of a PVar for a new value.+swapPVar :: PVar a -> a -> VTx a+swapPVar var new = do+    old <- readPVar var +    writePVar var new+    return old+{-# INLINE swapPVar #-}++-- | Each PVar has a stable address in the VCache. This address will+-- be very stable, but is not deterministic and isn't really something+-- you should treat as meaningful information about the PVar. Mostly, +-- this function exists to support hashtables or memoization with+-- PVar keys.+--+-- The Show instance for PVars will also show the address.+unsafePVarAddr :: PVar a -> Address+unsafePVarAddr = pvar_addr+{-# INLINE unsafePVarAddr #-}++-- | This function allows developers to access the reference count +-- for the PVar that is currently recorded in the database. This may+-- be useful for heuristic purposes. However, caveats are needed:+--+-- First, because the VCache writer operates in a background thread,+-- the reference count returned here may be slightly out of date.+--+-- Second, it is possible that VCache will eventually use some other+-- form of garbage collection than reference counting. This function+-- should be considered an unstable element of the API.+--+-- Root PVars start with one root reference.+unsafePVarRefct :: PVar a -> IO Int+unsafePVarRefct var = readRefctIO (pvar_space var) (pvar_addr var)+

@@ -0,0 +1,54 @@++module Database.VCache.Path+    ( vcacheSubdir+    , vcacheSubdirM+    ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Database.VCache.Types++maxPathLen :: Int+maxPathLen = 511  -- key size limit from LMDB 0.9.10++-- | VCache implements a simplified filesystem metaphor. Developers +-- can assign a distinct prefix for all PVars created by the VCache,+-- thus modeling namespaces or subdirectories. Assuming the normal +-- advice of opening the VCache only once in the main module, these+-- prefixes enable transparent, modular decomposition of a VCache +-- application without risk of name collisions.+--+-- VCache is simplistic about this: a prefix is appended directly.+-- If developers use subdir "foo" followed by "bar", the result is +-- the same as "foobar". Separators are left to local conventions.+-- Consider "foo/" and "bar/" to model filesystem subdirectories. +--                 +-- Paths have a limited maximum size of ~500 bytes, including the+-- final PVar name. A runtime error may be generated for oversized+-- paths. In practice, this should not be an issue. +--+-- Usage Note: Subdirectories allow developers to control risk of+-- namespace collisions between modules or plugins. But they are not+-- intended for domain data! Avoid dynamically creating directories+-- or named PVars based on runtime data. It's better to push most+-- domain logic and schema into the PVar layer, which is subject to+-- rich type safety, GC, potential versioning, and other benefits.+--+vcacheSubdir :: ByteString -> VCache -> VCache+vcacheSubdir p (VCache vs d) = +    let d' = subdir d p in+    if (BS.length d' > maxPathLen) +        then error ("VCache path too long: " ++ show d')+        else (VCache vs d')++-- | as vcacheSubdir, but returns Nothing if the path is too large.+vcacheSubdirM :: ByteString -> VCache -> Maybe VCache+vcacheSubdirM p (VCache vs d) =+    let d' = subdir d p in+    if (BS.length d' > maxPathLen)+        then Nothing+        else Just (VCache vs d')++subdir :: ByteString -> ByteString -> ByteString+subdir = BS.append+{-# INLINE subdir #-}

@@ -0,0 +1,146 @@++-- | read-write lock specialized for using LMDB with MDB_NOLOCK option+--+module Database.VCache.RWLock+    ( RWLock+    , newRWLock+    , withRWLock+    , withRdOnlyLock+    ) where++import Control.Monad+import Control.Exception+import Control.Concurrent.MVar+import Data.IORef+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++-- | RWLock+--+-- VCache uses LMDB with the MDB_NOLOCK option, mostly because I don't+-- want to deal with the whole issue of OS bound threads or a limit on+-- number of concurrent readers. Without locks, we essentially have one+-- valid snapshot. The writer can begin dismantling earlier snapshots+-- as needed to allocate pages. +--+-- RWLock essentially enforces this sort of frame-buffer concurrency.+data RWLock = RWLock +    { rwlock_frames :: !(MVar FB)+    , rwlock_writer :: !(MVar ())  -- enforce single writer+    }++data FB = FB !F !F+type F = IORef Frame+data Frame = Frame +    { frame_reader_next :: {-# UNPACK #-} !Int+    , frame_readers     :: !IntSet+    , frame_onClear     :: ![IO ()] -- actions to perform +    }+frame0 :: Frame+frame0 = Frame 1 IntSet.empty []++newRWLock :: IO RWLock+newRWLock = liftM2 RWLock (newMVar =<< newF2) newEmptyMVar where++newF2 :: IO FB+newF2 = liftM2 FB newF newF ++newF :: IO F+newF = newIORef frame0++withWriterMutex :: RWLock -> IO a -> IO a+withWriterMutex l = bracket_ getLock dropLock where+    getLock = putMVar (rwlock_writer l) ()+    dropLock = takeMVar (rwlock_writer l)+{-# INLINE withWriterMutex #-}++-- | Grab the current read-write lock for the duration of+-- an underlying action. This may wait on older readers. +withRWLock :: RWLock -> IO a -> IO a+withRWLock l action = withWriterMutex l $ do+    oldFrame <- rotateReaderFrames l +    mvWait <- newEmptyMVar+    onFrameCleared oldFrame (putMVar mvWait ())+    takeMVar mvWait+    action++-- rotate a fresh reader frame, and grab the oldest.+-- Thus should only be performed while holding the writer lock.+rotateReaderFrames :: RWLock -> IO F+rotateReaderFrames l = mask_ $ do+    let var = rwlock_frames l+    f0 <- newF+    (FB f1 f2) <- takeMVar var+    putMVar var (FB f0 f1)+    return f2++--+-- NOTE: Each of these 'frames' actually contains readers of two+-- transactions. Alignment between LMDB transactions and VCache+-- RWLock isn't exact. +--+-- Each write lock will rotate reader frames just once: +--+--     (f1,f2) → (f0,f1) returning f2+--+-- Writer is working on LMDB frame N.+--+-- f0 will have readers for frame N-1 and (after commit) for N.+-- f1 will have readers for frame N-2 and some for N-1.+-- f2 will have readers for frame N-3 and some for N-2.+--+-- LMDB guarantees that the data pages for frames N-1 and N-2 are +-- intact. However, frame N-3 will be dismantled while building+-- frame N. Thus, we must wait for f2 readers to finish before we +-- begin the writer N transaction.+--+-- If we assume short-running readers and long-running writers, it+-- is rare that the writer ever needs to wait on readers. Readers +-- never need to wait on the writer. This assumption is achieved by+-- batching writes  in VCache.+--+++-- perform some action when a frame is cleared +-- performs immediately, if possible.+onFrameCleared :: F -> IO () -> IO ()+onFrameCleared f action = atomicModifyIORef f addAction >>= id where+    addAction frame =+        let bAlreadyClear = IntSet.null (frame_readers frame) in+        if bAlreadyClear then (frame0,action) else+        let onClear' = action : frame_onClear frame in+        let frame' = frame { frame_onClear = onClear' } in+        (frame', return ())++-- | Grab a read-only lock for the duration of some IO action. +--+-- Readers never need to wait on the writer.+withRdOnlyLock :: RWLock -> IO a -> IO a+withRdOnlyLock l = bracket (newReader l) releaseReader . const++newtype Reader = Reader { releaseReader :: IO () }++-- obtains a reader handle; returns function to release reader.+newReader :: RWLock -> IO Reader+newReader l = mask_ $ do+    let var = rwlock_frames l+    fb@(FB f _) <- takeMVar var+    r <- atomicModifyIORef f addReader+    putMVar var fb+    return (Reader (delReader f r))++addReader :: Frame -> (Frame, Int)+addReader f =+    let r     = frame_reader_next f in+    let rdrs' = IntSet.insert r (frame_readers f) in+    let f'    = f { frame_reader_next = (r + 1)+                  , frame_readers = rdrs' } in+    (f', r)++delReader :: F -> Int -> IO ()+delReader f r = atomicModifyIORef f del >>= sequence_ where+    del frm =+        let rdrs' = IntSet.delete r (frame_readers frm) in+        if IntSet.null rdrs' then (frame0, frame_onClear frm) else+        let frm' = frm { frame_readers = rdrs' } in+        (frm', []) 

@@ -0,0 +1,92 @@++module Database.VCache.Read+    ( readAddrIO+    , readRefctIO+    ) where++import Control.Monad+import qualified Data.Map.Strict as Map+import qualified Data.List as L+import Control.Concurrent.MVar+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc++import Database.LMDB.Raw++import Database.VCache.Types+import Database.VCache.VGetInit+import Database.VCache.VGetAux+import Database.VCache.Refct++-- | Parse contents at a given address. Returns both the value and the+-- cache weight, or fails. This first tries reading the database, then+-- falls back to reading from recent allocation frames. +readAddrIO :: VSpace -> Address -> VGet a -> IO (a, Int)+readAddrIO vc addr parser = +    alloca $ \ pAddr ->+    poke pAddr addr >>+    let vAddr = MDB_val { mv_data = castPtr pAddr+                        , mv_size = fromIntegral (sizeOf addr)+                        }+    in+    withRdOnlyTxn vc $ \ txn -> +    let db = vcache_db_memory vc in+    let rd = readVal vc parser in+    mdb_get' txn db vAddr >>= \ mbData ->+    case mbData of+        Just vData -> rd vData -- found data in database (ideal)+        Nothing -> -- since not in the database, try the allocator+            let ff = Map.lookup addr . alloc_list in+            readMVar (vcache_memory vc) >>= \ memory ->+            let ac = mem_alloc memory in+            case allocFrameSearch ff ac of+                Just an -> withByteStringVal (alloc_data an) rd -- found data in allocator+                Nothing -> fail $ "VCache: address " ++ show addr ++ " is undefined!"++readVal :: VSpace -> VGet a -> MDB_val -> IO (a, Int)+readVal vc p v = _vget (vgetFull p) s0 >>= retv where+    s0 = VGetS { vget_children = []+               , vget_target = mv_data v+               , vget_limit = mv_data v `plusPtr` fromIntegral (mv_size v)+               , vget_space = vc+               }+    retv (VGetR result _) = return result+    retv (VGetE eMsg) = fail eMsg++-- get the full value and weight+vgetFull :: VGet a -> VGet (a, Int)+vgetFull parser = do+    vgetInit +    w <- vgetWeight+    r <- parser+    assertDone+    return (r,w)++assertDone :: VGet ()+assertDone = isEmpty >>= \ b -> unless b (fail emsg) where+    emsg = "VCache: failed to read full input" +{-# INLINE assertDone #-}++vgetWeight :: VGet Int+vgetWeight = VGet $ \ s ->+    let nBytes = vget_limit s `minusPtr` vget_target s in+    let nRefs = L.length (vget_children s) in+    let w = cacheWeight nBytes nRefs in+    w `seq` return (VGetR w s)+{-# INLINE vgetWeight #-}+++-- | Read a reference count for a given address. +readRefctIO :: VSpace -> Address -> IO Int+readRefctIO vc addr = +    alloca $ \ pAddr ->+    withRdOnlyTxn vc $ \ txn -> +    poke pAddr addr >>+    let vAddr = MDB_val { mv_data = castPtr pAddr+                        , mv_size = fromIntegral (sizeOf addr) }+    in+    mdb_get' txn (vcache_db_refcts vc) vAddr >>= \ mbData ->+    maybe (return 0) readRefctBytes mbData++

@@ -0,0 +1,45 @@++-- Code for reading and writing reference counts.+module Database.VCache.Refct +    ( readRefctBytes+    , toRefctBytes+    , writeRefctBytes+    , Refct+    ) where++import Control.Exception+import Data.Word+import Data.Bits+import Foreign.Ptr+import Foreign.Storable+import Database.LMDB.Raw++type Refct = Int++-- simple variable-width encoding for reference counts. Encoding is +-- base256 then adding 1. (The lead byte should always be non-zero,+-- but that isn't checked here.)+readRefctBytes :: MDB_val -> IO Refct+readRefctBytes v = rd (mv_data v) (mv_size v) 0 where+    rd _ 0 rc = return (rc + 1)+    rd p n rc = do+        w8 <- peek p+        let rc' = (rc `shiftL` 8) .|. (fromIntegral w8) +        rd (p `plusPtr` 1) (n - 1) rc'++-- compute list of bytes for a big-endian encoding. +-- Reference count must be positive!+toRefctBytes :: Refct -> [Word8]+toRefctBytes = rcb [] . subtract 1 . assertPositive where+    rcb l 0 = l+    rcb l rc = rcb (fromIntegral rc : l) (rc `shiftR` 8)+    assertPositive n = assert (n > 0) n++-- write a reference variable-width count into an MDB_val.+--+-- Note: given buffer should be large enough for any reference count. +writeRefctBytes :: Ptr Word8 -> Refct -> IO MDB_val+writeRefctBytes p0 = wrcb p0 0 . toRefctBytes where+    wrcb _ n [] = return $! MDB_val { mv_data = p0, mv_size = n }+    wrcb p n (b:bs) = do { poke p b ; wrcb (p `plusPtr` 1) (n + 1) bs }+

@@ -0,0 +1,93 @@++module Database.VCache.Stats+    ( VCacheStats(..)+    , vcacheStats+    ) where++import Data.IORef+import Control.Concurrent.MVar+import qualified Data.Map.Strict as Map++import Database.LMDB.Raw+import Database.VCache.Types+++-- | Miscellaneous statistics for a VCache instance. These are not+-- necessarily consistent, current, or useful. But they can say a+-- a bit about the liveliness and health of a VCache system.+data VCacheStats = VCacheStats+        { vcstat_file_size      :: {-# UNPACK #-} !Int  -- ^ estimated database file size (in bytes)+        , vcstat_vref_count     :: {-# UNPACK #-} !Int  -- ^ number of immutable values in the database+        , vcstat_pvar_count     :: {-# UNPACK #-} !Int  -- ^ number of mutable PVars in the database+        , vcstat_root_count     :: {-# UNPACK #-} !Int  -- ^ number of named roots (a subset of PVars)+        , vcstat_mem_vrefs      :: {-# UNPACK #-} !Int  -- ^ number of VRefs in Haskell process memory (some may share address)+        , vcstat_mem_pvars      :: {-# UNPACK #-} !Int  -- ^ number of PVars in Haskell process memory+        , vcstat_mem_addrs      :: {-# UNPACK #-} !Int  -- ^ number of addresses held by Haskell process memory+        , vcstat_eph_count      :: {-# UNPACK #-} !Int  -- ^ number of addresses with zero references+        , vcstat_alloc_pos      :: {-# UNPACK #-} !Address -- ^ address to next be used by allocator+        , vcstat_alloc_count    :: {-# UNPACK #-} !Int  -- ^ number of allocations by this process +        , vcstat_cache_count    :: {-# UNPACK #-} !Int  -- ^ number of VRefs with cached values+        , vcstat_cache_limit    :: {-# UNPACK #-} !Int  -- ^ target cache size +        , vcstat_cache_size     :: {-# UNPACK #-} !Int  -- ^ estimated cache size in bytes+        , vcstat_gc_count       :: {-# UNPACK #-} !Int  -- ^ number of addresses GC'd by this process+        , vcstat_write_pvars    :: {-# UNPACK #-} !Int  -- ^ number of PVar updates to disk (after batching)+        , vcstat_write_sync     :: {-# UNPACK #-} !Int  -- ^ number of sync requests (~ durable transactions)+        , vcstat_write_frames   :: {-# UNPACK #-} !Int  -- ^ number of LMDB-layer transactions by this process+        } deriving (Show, Ord, Eq)++-- | Compute some miscellaneous statistics for a VCache instance at+-- runtime. These aren't really useful for anything, except to gain+-- some confidence about activity or comprehension of performance. +vcacheStats :: VSpace -> IO VCacheStats+vcacheStats vc = withRdOnlyTxn vc $ \ txnStat -> do+    let db = vcache_db_env vc+    envInfo <- mdb_env_info db+    envStat <- mdb_env_stat db+    dbMemStat <- mdb_stat' txnStat (vcache_db_memory vc)+    rootStat <- mdb_stat' txnStat (vcache_db_vroots vc)+    hashStat <- mdb_stat' txnStat (vcache_db_caddrs vc)+    ephStat <- mdb_stat' txnStat (vcache_db_refct0 vc)+    memory <- readMVar (vcache_memory vc)+    gcCount <- readIORef (vcache_gc_count vc)+    wct <- readIORef (vcache_ct_writes vc)+    cLimit <- readIORef (vcache_climit vc)+    cSizeEst <- readIORef (vcache_csize vc)+    +    let fileSize = (1 + (fromIntegral $ me_last_pgno envInfo)) +                 * (fromIntegral $ ms_psize envStat)+    let vrefCount = (fromIntegral $ ms_entries hashStat) +    let pvarCount = (fromIntegral $ ms_entries dbMemStat) - vrefCount+    let ephCount = (fromIntegral $ ms_entries ephStat)+    let rootCount = (fromIntegral $ ms_entries rootStat)+    let cvrefsCount = Map.foldl' (\ a b -> a + Map.size b) 0 (mem_cvrefs memory)+    let evrefsCount = Map.foldl' (\ a b -> a + Map.size b) 0 (mem_evrefs memory)+    let cacheSizeBytes = ceiling $ fromIntegral (Map.size (mem_cvrefs memory))+                                 * csze_addr_size cSizeEst+    let memVRefsCount = cvrefsCount + evrefsCount+    let memPVarsCount = Map.size (mem_pvars memory)+    let memAddrsCount = Map.size (mem_pvars memory) +                      + Map.size (mem_cvrefs memory) +                      + Map.size (mem_evrefs memory)+    let allocPos = alloc_new_addr (mem_alloc memory)+    let allocDiff = allocPos - vcache_alloc_init vc+    let allocCount = fromIntegral $ allocDiff `div` 2 +    return $ VCacheStats+        { vcstat_file_size = fileSize+        , vcstat_vref_count = vrefCount+        , vcstat_pvar_count = pvarCount+        , vcstat_root_count = rootCount+        , vcstat_mem_vrefs = memVRefsCount+        , vcstat_mem_pvars = memPVarsCount+        , vcstat_mem_addrs = memAddrsCount+        , vcstat_eph_count = ephCount+        , vcstat_alloc_pos = allocPos+        , vcstat_alloc_count = allocCount+        , vcstat_cache_count = cvrefsCount+        , vcstat_cache_limit = cLimit+        , vcstat_cache_size = cacheSizeBytes+        , vcstat_write_sync = wct_sync wct+        , vcstat_write_pvars = wct_pvars wct+        , vcstat_write_frames = wct_frames wct+        , vcstat_gc_count = gcCount+        }+

@@ -0,0 +1,19 @@+++module Database.VCache.Sync+    ( vcacheSync+    ) where++import Database.VCache.Types+import Database.VCache.VTx++-- | If you use a lot of non-durable transactions, you may wish to+-- ensure they are synchronized to disk at various times. vcacheSync+-- will simply wait for all transactions committed up to this point.+-- This is equivalent to running a durable, read-only transaction.+--+-- It is recommended you perform a vcacheSync as part of graceful+-- shutdown of any application that uses VCache.+--+vcacheSync :: VSpace -> IO ()+vcacheSync vc = runVTx vc markDurable

@@ -0,0 +1,663 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}++-- Internal file. Lots of types. Lots of coupling.+module Database.VCache.Types+    ( Address, isVRefAddr, isPVarAddr+    , VRef(..), Cache(..), CacheMode(..)+    , VREph(..), VREphMap, addVREph, takeVREph+    , PVar(..), RDV(..)+    , PVEph(..), PVEphMap, addPVEph+    , VCache(..), VSpace(..)+    , VPut(..), VPutS(..), VPutR(..), PutChild(..), putChildAddr+    , VGet(..), VGetS(..), VGetR(..)+    , VCacheable(..)+    , Allocator(..), AllocFrame(..), Allocation(..)+    , GC(..), GCFrame(..)+    , Memory(..)+    , VTx(..), VTxState(..), TxW(..), VTxBatch(..)+    , Writes(..), WriteLog, WriteCt(..)+    , CacheSizeEst(..)++    -- misc. utilities+    , allocFrameSearch+    , recentGC++    , withRdOnlyTxn+    , withByteStringVal++    , getVTxSpace, markForWrite, liftSTM+    , mkVRefCache, cacheWeight, cacheModeBits, touchCache+    ) where++import Data.Bits+import Data.Word+import Data.Function (on)+import Data.Typeable+import Data.IORef+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BSI+import Control.Monad+import Control.Monad.Trans.Class (lift)+import Control.Monad.STM (STM)+import Control.Applicative+import Control.Concurrent.MVar+import Control.Concurrent.STM.TVar+import Control.Monad.Trans.State.Strict+import Control.Exception (bracket)+import System.Mem.Weak (Weak)+import System.FileLock (FileLock)+import Database.LMDB.Raw+import Foreign.Ptr+import Foreign.ForeignPtr (withForeignPtr)++import Database.VCache.RWLock++-- | An address in the VCache address space+type Address = Word64 -- with '0' as special case++-- | VRefs and PVars are divided among odds and evens.+isVRefAddr, isPVarAddr :: Address -> Bool+isVRefAddr addr = (0 == (1 .&. addr))+isPVarAddr = not . isVRefAddr+{-# INLINE isVRefAddr #-}+{-# INLINE isPVarAddr #-}++-- | A VRef is an opaque reference to an immutable value backed by a+-- file, specifically via LMDB. The primary motivation for VRefs is+-- to support memory-cached values, i.e. very large data structures+-- that should not be stored in all at once in RAM.+--+-- The API involving VRefs is conceptually pure.+--+-- > vref  :: (VCacheable a) => VSpace -> a -> VRef a+-- > deref :: VRef a -> a+--+-- Under the hood, each VRef has a 64-bit address and a local cache.+-- When dereferenced, the cache is checked or the value is read from+-- the database then cached. Variants of vref and deref control cache+-- behavior.+-- +-- VCacheable values may themselves contain VRefs and PVars, storing+-- just the address. Very large structured data is readily modeled+-- by using VRefs to load just the pieces you need. However, there is+-- one major constraint:+--+-- VRefs may only represent acyclic structures. +--+-- If developers want cyclic structure, they need a PVar in the chain.+-- Alternatively, cycles may be modeled indirectly using explicit IDs.+-- +-- Besides memory caching, VRefs also utilize structure sharing: all+-- VRefs sharing the same serialized representation will share the +-- same address. Structure sharing enables VRefs to be compared for+-- equality without violating conceptual purity. It also simplifies+-- reasoning about idempotence, storage costs, memoization, etc..+--+data VRef a = VRef +    { vref_addr   :: {-# UNPACK #-} !Address            -- ^ address within the cache+    , vref_cache  :: {-# UNPACK #-} !(IORef (Cache a))  -- ^ cached value & weak refs +    , vref_space  :: !VSpace                            -- ^ virtual address space for VRef+    , vref_type   :: !TypeRep                           -- ^ type of value held by VRef+    , vref_parse  :: !(VGet a)                          -- ^ parser for this VRef+    } deriving (Typeable)+instance Eq (VRef a) where (==) = (==) `on` vref_cache+instance Show (VRef a) where +    showsPrec _ v = showString "VRef#" . shows (vref_addr v)+                  . showString "::" . shows (vref_type v)++-- For every VRef we have in memory, we need an ephemeron in a table.+-- This ephemeron table supports structure sharing, caching, and GC.+-- I model this ephemeron by use of `mkWeakMVar`.+data VREph = forall a . VREph +    { vreph_addr  :: {-# UNPACK #-} !Address+    , vreph_type  :: !TypeRep+    , vreph_cache :: {-# UNPACK #-} !(Weak (IORef (Cache a)))+    } +type VREphMap = Map Address (Map TypeRep VREph)+    -- Address is at the top layer of the map mostly to simplify GC.+++addVREph :: VREph -> VREphMap -> VREphMap+addVREph e = Map.alter (Just . maybe i0 ins) (vreph_addr e) where+    ty = vreph_type e+    i0 = Map.singleton ty e+    ins = Map.insert ty e+{-# INLINABLE addVREph #-}+                    +takeVREph :: Address -> TypeRep -> VREphMap -> Maybe (VREph, VREphMap)+takeVREph !addr !ty !em = +    case Map.lookup addr em of+         Nothing -> Nothing+         Just tym -> case Map.lookup ty tym of+            Nothing -> Nothing+            Just e -> +                let em' = if (1 == Map.size tym)+                        then Map.delete addr em +                        else Map.insert addr (Map.delete ty tym) em+                in+                Just (e, em') +{-# INLINABLE takeVREph #-}+++-- TODO: I may need a way to "reserve" VRef addresses for destruction, +-- i.e. such that I can guard against ++-- Every VRef contains its own cache. Thus, there is no extra lookup+-- overhead to test the cache. The cache includes an integer as a+-- bitfield to describe mode.+data Cache a +        = NotCached +        | Cached a {-# UNPACK #-} !Word16++--+-- cache bitfield for mode:+--   bit 0..4: heuristic weight, log scale+--     weight = bytes + 80 * (deps + 1)+--     log scale: 2^(N+6), max N=31+--   bits 5..6: cache mode 0..3+--   bit 7: toggle; set 1 by manager, 0 by derefc+--+-- The weight is used for estimates of cache size, and at the moment+-- cache mode is the primary factor in deciding survival of an object+-- after the cache manager touches it. Higher bits might be used to +-- estimate use and extend survival, but for now don't do anything.+--+++-- | Cache modes are used when deciding, heuristically, whether to+-- clear a value from cache. These modes don't have precise meaning,+-- but there is a general intention: higher numbered modes indicate+-- that VCache should hold onto a value for longer or with greater+-- priority. In the current implementation, CacheMode is used as a+-- pool of 'hitpoints' in a gaming metaphor: if an entry would be+-- removed, but its mode is greater than zero, the mode is reduced+-- instead.+--+-- The default for vref and deref is CacheMode1. Use of vrefc or +-- derefc may specify other modes. Cache mode is monotonic: if+-- the same VRef is deref'd with two different modes, the higher+-- mode will be favored.+--+-- Note: Regardless of mode, a VRef that is fully GC'd from the+-- Haskell layer will ensure any cached content is also GC'd.+-- +data CacheMode+        = CacheMode0+        | CacheMode1+        | CacheMode2+        | CacheMode3+        deriving (Eq, Ord, Show)++cacheModeBits :: CacheMode -> Word16+cacheModeBits CacheMode0 = 0+cacheModeBits CacheMode1 = 1 `shiftL` 5+cacheModeBits CacheMode2 = 2 `shiftL` 5+cacheModeBits CacheMode3 = 3 `shiftL` 5+++-- | clear bit 7; adjust cache mode monotonically.+touchCache :: CacheMode -> Word16 -> Word16+touchCache !cm !w =+    let cb' = (w .&. 0x60) `max` cacheModeBits cm in+    (w .&. 0xff1f) .|. cb'+{-# INLINE touchCache #-}++mkVRefCache :: a -> Int -> CacheMode -> Cache a+mkVRefCache val !w !cm = Cached val cw where+    cw = m .|. cs 0 64+    cs r k = if ((k > w) || (r == 0x1f)) then r else cs (r+1) (k*2)+    m = cacheModeBits cm++cacheWeight :: Int -> Int -> Int+cacheWeight !nBytes !nDeps = nBytes + (80 * nDeps)+{-# INLINE cacheWeight #-}++-- | A PVar is a mutable variable backed by VCache. PVars can be read+-- or updated transactionally (see VTx), and may store by reference+-- as part of domain data (see VCacheable). +--+-- A PVar is not cached. If you want memory cached contents, you'll +-- need a PVar that contains one or more VRefs. However, the first +-- read from a PVar is lazy, so merely referencing a PVar does not +-- require loading its contents into memory.+--+-- Due to how updates are batched, high frequency or bursty updates +-- on a PVar should perform acceptably. Not every intermediate value +-- is written to disk.+--+-- Anonymous PVars will be garbage collected if not in use. Persistence+-- requires ultimately tying contents to named roots (cf. loadRootPVar).+-- Garbage collection is based on reference counting, so developers must+-- be cautious when working with cyclic data, i.e. break cycles before+-- disconnecting them from root.+--+-- Note: PVars must never contain undefined or error values, nor any+-- value that cannot be serialized by a VCacheable instance. +--+data PVar a = PVar+    { pvar_addr  :: {-# UNPACK #-} !Address+    , pvar_data  :: {-# UNPACK #-} !(TVar (RDV a))+    , pvar_space :: !VSpace -- ^ virtual address space for PVar+    , pvar_type  :: !TypeRep+    , pvar_write :: !(a -> VPut ())+    } deriving (Typeable)+instance Eq (PVar a) where (==) = (==) `on` pvar_data+instance Show (PVar a) where +    showsPrec _ pv = showString "PVar#" . shows (pvar_addr pv)+                   . showString "::" . shows (pvar_type pv)++-- ephemeron table for PVars.+data PVEph = forall a . PVEph +    { pveph_addr :: {-# UNPACK #-} !Address+    , pveph_type :: !TypeRep+    , pveph_data :: {-# UNPACK #-} !(Weak (TVar (RDV a)))+    }+type PVEphMap = Map Address PVEph++addPVEph :: PVEph -> PVEphMap -> PVEphMap+addPVEph pve = Map.insert (pveph_addr pve) pve+{-# INLINE addPVEph #-}++-- I need some way to force an evaluation when a PVar is first+-- read, i.e. in order to load the initial value, without forcing+-- on every read. For the moment, I'm using a simple type wrapper.+data RDV a = RDV a++-- | VCache supports a filesystem-backed address space plus a set of+-- persistent, named root variables that can be loaded from one run +-- of the application to another. VCache supports a simple filesystem+-- like model to resist namespace collisions between named roots.+--+-- > openVCache   :: Int -> FilePath -> IO VCache+-- > vcacheSubdir :: ByteString -> VCache -> VCache+-- > loadRootPVar :: (VCacheable a) => VCache -> ByteString -> a -> PVar a+--+-- The normal use of VCache is to open VCache in the main function, +-- use vcacheSubdir for each major framework, plugin, or independent+-- component that might need persistent storage, then load at most a+-- few root PVars per component. Most domain modeling should be at +-- the data layer, i.e. the type held by the PVar.+--+-- See VSpace, VRef, and PVar for more information.+data VCache = VCache+    { vcache_space :: !VSpace -- ^ virtual address space for VCache+    , vcache_path  :: !ByteString+    } deriving (Eq)++-- | VSpace represents the virtual address space used by VCache. Except+-- for loadRootPVar, most operations use VSpace rather than the VCache.+-- VSpace is accessed by vcache_space, vref_space, or pvar_space.+--+-- Addresses from this space are allocated incrementally, odds to PVars+-- and evens to VRefs, independent of object size. The space is elastic:+-- it isn't a problem to change the size of PVars (even drastically) from+-- one update to another.+--+-- In theory, VSpace could run out of 64-bit addresses. In practice, this+-- isn't a real concern - a quarter million years at a sustained million +-- allocations per second. +--+data VSpace = VSpace+    { vcache_lockfile   :: !FileLock -- block concurrent use of VCache file++    -- LMDB contents. +    , vcache_db_env     :: !MDB_env+    , vcache_db_memory  :: {-# UNPACK #-} !MDB_dbi' -- address → value+    , vcache_db_vroots  :: {-# UNPACK #-} !MDB_dbi' -- path → address +    , vcache_db_caddrs  :: {-# UNPACK #-} !MDB_dbi' -- hashval → [address]+    , vcache_db_refcts  :: {-# UNPACK #-} !MDB_dbi' -- address → Word64+    , vcache_db_refct0  :: {-# UNPACK #-} !MDB_dbi' -- address → ()++    , vcache_memory     :: !(MVar Memory) -- Haskell-layer memory management+    , vcache_signal     :: !(MVar ()) -- signal writer that work is available+    , vcache_writes     :: !(TVar Writes) -- STM layer PVar writes+    , vcache_rwlock     :: !RWLock -- replace gap left by MDB_NOLOCK+++    -- Signal writes mostly exists to prevent GC of PVars until after +    -- any updated PVars are durable. I also use it to maintain stats. :)+    , vcache_signal_writes :: !(Writes -> IO ()) -- signal durable writes+    , vcache_ct_writes  :: !(IORef WriteCt) -- (stat) information about writes++    , vcache_alloc_init :: {-# UNPACK #-} !Address -- (for stats) initial allocator on open++    , vcache_gc_start   :: !(IORef (Maybe Address)) -- supports incremental GC+    , vcache_gc_count   :: !(IORef Int) -- (stat) number of addresses GC'd++    , vcache_climit     :: !(IORef Int) -- targeted max cache size in bytes+    , vcache_csize      :: !(IORef CacheSizeEst) -- estimated cache sizes+++    -- share persistent variables for safe STM++    -- Further, I need...+    --   log or queue of 'new' vrefs and pvars, +    --     including those still being written+    --   a thread performing writes and incremental GC+    --   a channel to talk to that thread+    --   queue of MVars waiting on synchronization/flush.++    }++instance Eq VSpace where (==) = (==) `on` vcache_signal++-- needed: a transactional queue of updates to PVars++-- | The Allocator both tracks the 'bump-pointer' address for the+-- next allocation, plus in-memory logs for recent and near future +-- allocations.+--+-- The log has three frames, based on the following observations:+--+-- * frames are rotated when the writer lock is held+-- * when the writer lock is held, readers exist for two prior frames+-- * readers from two frames earlier use log to find allocations from:+--   * the previous write frame+--   * the current write frame+--   * the next write frame (allocated during write)+-- +-- Each write frame includes content for both the primary (db_memory)+-- and secondary (db_caddrs or db_vroots) indices. +--+-- Normal Data.Map is favored because I want the keys in sorted order+-- when writing into the LMDB layer anyway.+--+data Allocator = Allocator+    { alloc_new_addr :: {-# UNPACK #-} !Address -- next address+    , alloc_frm_next :: !AllocFrame -- frame N+1 (next step)+    , alloc_frm_curr :: !AllocFrame -- frame N   (curr step)+    , alloc_frm_prev :: !AllocFrame -- frame N-1 (prev step)+    }++data AllocFrame = AllocFrame +    { alloc_list :: !(Map Address Allocation)       -- allocated addresses+    , alloc_seek :: !(Map ByteString [Allocation])  -- named addresses+    , alloc_init :: {-# UNPACK #-} !Address         -- alloc_new_addr at frame init.+    }++data Allocation = Allocation+    { alloc_name :: {-# UNPACK #-} !ByteString -- VRef hash or PVar path, or empty for anon PVar+    , alloc_data :: {-# UNPACK #-} !ByteString -- initial content+    , alloc_addr :: {-# UNPACK #-} !Address    -- where to save content+    , alloc_deps :: [PutChild]                 -- keepalive for allocation+    }++allocFrameSearch :: (AllocFrame -> Maybe a) -> Allocator -> Maybe a+allocFrameSearch f a = f n <|> f c <|> f p where+    n = alloc_frm_next a+    c = alloc_frm_curr a+    p = alloc_frm_prev a++-- | In addition to recent allocations, we track garbage collection.+-- The goal here is to prevent revival of VRefs after we decide to+-- delete them. So, when we try to allocate a VRef, we'll check to+-- see if it's address has been targeted for deletion.+--+-- To keep this simple, GC is performed by the writer thread. Other+-- threads must worry about reading outdated reference counts. This+-- also means we only need the two frames: a reader of frame N-2  +-- only needs to prevent revival of VRefs GC'd at N-1 or N.+--+data GC = GC +    { gc_frm_curr :: !GCFrame+    , gc_frm_prev :: !GCFrame+    } +data GCFrame = forall a . GCFrame !(Map Address a)+    -- The concrete map type depends on the writer++recentGC :: GC -> Address -> Bool+recentGC gc addr = ff c || ff p where+    ff (GCFrame m) = Map.member addr m+    c = gc_frm_curr gc+    p = gc_frm_prev gc+{-# INLINE recentGC #-}++-- | The Memory datatype tracks allocations, GC, and ephemeron+-- tables for tracking both PVars and VRefs in Haskell memory.+-- These are combined into one type mostly because typical +-- operations on them are atomic... and STM isn't permitted +-- because vref constructors are used with unsafePerformIO.+data Memory = Memory+    { mem_evrefs :: !VREphMap   -- ^ VRefs with empty cache.+    , mem_cvrefs :: !VREphMap   -- ^ VRefs with full cache.+    , mem_pvars  :: !PVEphMap   -- ^ In-memory PVars+    , mem_gc     :: !GC         -- ^ recently GC'd addresses (two frames)+    , mem_alloc  :: !Allocator  -- ^ recent or pending allocations (three frames)+    }++++-- simple read-only operations +--  LMDB transaction is aborted when finished, so cannot open DBIs+withRdOnlyTxn :: VSpace -> (MDB_txn -> IO a) -> IO a+withRdOnlyTxn vc = withLock . bracket newTX endTX where+    withLock = withRdOnlyLock (vcache_rwlock vc)+    newTX = mdb_txn_begin (vcache_db_env vc) Nothing True+    endTX = mdb_txn_abort+{-# INLINE withRdOnlyTxn #-}++withByteStringVal :: ByteString -> (MDB_val -> IO a) -> IO a+withByteStringVal (BSI.PS fp off len) action = withForeignPtr fp $ \ p ->+    action $ MDB_val { mv_size = fromIntegral len, mv_data = p `plusPtr` off }+{-# INLINE withByteStringVal #-}++-- | The VTx transactions allow developers to atomically manipulate+-- PVars and STM resources (TVars, TArrays, etc..). VTx is a thin+-- layer above STM, additionally tracking which PVars are written so+-- it can push the batch to a background writer thread upon commit.+-- +-- VTx supports full ACID semantics (atomic, consistent, isolated,+-- durable), but durability is optional (see markDurable). +-- +newtype VTx a = VTx { _vtx :: StateT VTxState STM a }+    deriving (Monad, Functor, Applicative, Alternative, MonadPlus)++-- | In addition to the STM transaction, I need to track whether+-- the transaction is durable (such that developers may choose +-- based on internal domain-model concerns) and which variables+-- have been read or written. All PVars involved must be part of+-- the same VSpace.+data VTxState = VTxState+    { vtx_space     :: !VSpace+    , vtx_writes    :: !WriteLog+    , vtx_durable   :: !Bool+    }++-- | run an arbitrary STM operation as part of a VTx transaction.+liftSTM :: STM a -> VTx a+liftSTM = VTx . lift+{-# INLINE liftSTM #-}++getVTxSpace :: VTx VSpace+getVTxSpace = VTx (gets vtx_space)+{-# INLINE getVTxSpace #-}++-- | add a PVar write to the VTxState.+-- (Does not modify the underlying TVar.)+markForWrite :: PVar a -> a -> VTx ()+markForWrite pv a = VTx $ modify $ \ vtx ->+    let txw = TxW pv a in+    let addr = pvar_addr pv in+    let writes' = Map.insert addr txw (vtx_writes vtx) in+    vtx { vtx_writes = writes' }+{-# INLINE markForWrite #-}+++-- | Estimate for cache size is based on random samples with an+-- exponential moving average. It isn't very precise, but it is+-- good enough for the purpose of guiding aggressiveness of the+-- exponential decay model.+data CacheSizeEst = CacheSizeEst+    { csze_addr_size  :: {-# UNPACK #-} !Double -- average of sizes+    , csze_addr_sqsz  :: {-# UNPACK #-} !Double -- average of squares+    }++++type WriteLog  = Map Address TxW+data TxW = forall a . TxW !(PVar a) a+    -- Note: I can either record just the PVar, or the PVar and its value.+    -- The latter is favorable because it avoids risk of creating very large+    -- transactions in the writer thread (i.e. to read the updated PVars).++data Writes = Writes +    { write_data :: !WriteLog+    , write_sync :: ![MVar ()]+    }+    -- Design Thoughts: It might be worthwhile to separate the writelog+    -- and synchronization, i.e. to potentially reduce conflicts between+    -- transactions. But I'll leave this to later.++data WriteCt = WriteCt+    { wct_frames :: {-# UNPACK #-} !Int -- how many write frames+    , wct_pvars  :: {-# UNPACK #-} !Int -- how many PVars written+    , wct_sync   :: {-# UNPACK #-} !Int -- how many sync requests+    }++data VTxBatch = VTxBatch SyncOp WriteLog +type SyncOp = IO () -- called after write is synchronized.++type Ptr8 = Ptr Word8+type PtrIni = Ptr8+type PtrEnd = Ptr8+type PtrLoc = Ptr8++-- | VPut is a serialization monad akin to Data.Binary or Data.Cereal.+-- However, VPut is not restricted to pure binaries: developers may+-- include VRefs and PVars in the output.+--+-- Content emitted by VPut will generally be read only by VCache. So+-- it may be worth optimizing some cases, such as lists are written +-- in reverse such that readers won't need to reverse the list.+newtype VPut a = VPut { _vput :: VPutS -> IO (VPutR a) }+data VPutS = VPutS +    { vput_space    :: !VSpace +    , vput_children :: ![PutChild] -- ^ addresses written+    , vput_buffer   :: !(IORef PtrIni) -- ^ current buffer for easy free+    , vput_target   :: {-# UNPACK #-} !PtrLoc -- ^ location within buffer+    , vput_limit    :: {-# UNPACK #-} !PtrEnd -- ^ current limit for input+    }+    -- note: vput_buffer is an IORef mostly to simplify error handling.+    --  On error, we'll need to free the buffer. However, it may be +    --  reallocated many times during serialization of a large value,+    --  so we need easy access to the final value.+data PutChild = forall a . PutChild (Either (PVar a) (VRef a))++putChildAddr :: PutChild -> Address+putChildAddr (PutChild (Left (PVar { pvar_addr = x }))) = x+putChildAddr (PutChild (Right (VRef { vref_addr = x }))) = x+++data VPutR r = VPutR+    { vput_result :: r+    , vput_state  :: !VPutS+    }++instance Functor VPut where +    fmap f m = VPut $ \ s -> +        _vput m s >>= \ (VPutR r s') ->+        return (VPutR (f r) s')+    {-# INLINE fmap #-}+instance Applicative VPut where+    pure = return+    (<*>) = ap+    {-# INLINE pure #-}+    {-# INLINE (<*>) #-}+instance Monad VPut where+    fail msg = VPut (\ _ -> fail ("VCache.VPut.fail " ++ msg))+    return r = VPut (\ s -> return (VPutR r s))+    m >>= k = VPut $ \ s ->+        _vput m s >>= \ (VPutR r s') ->+        _vput (k r) s'+    m >> k = VPut $ \ s ->+        _vput m s >>= \ (VPutR _ s') ->+        _vput k s'+    {-# INLINE return #-}+    {-# INLINE (>>=) #-}+    {-# INLINE (>>) #-}+++-- | VGet is a parser combinator monad for VCache. Unlike pure binary+-- parsers, VGet supports reads from a stack of VRefs and PVars to +-- directly model structured data.+--+newtype VGet a = VGet { _vget :: VGetS -> IO (VGetR a) }+data VGetS = VGetS +    { vget_children :: ![Address]+    , vget_target   :: {-# UNPACK #-} !PtrLoc+    , vget_limit    :: {-# UNPACK #-} !PtrEnd+    , vget_space    :: !VSpace+    }+data VGetR r +    = VGetR r !VGetS+    | VGetE String+++instance Functor VGet where+    fmap f m = VGet $ \ s ->+        _vget m s >>= \ c ->+        return $ case c of+            VGetR r s' -> VGetR (f r) s'+            VGetE msg -> VGetE msg +    {-# INLINE fmap #-}+instance Applicative VGet where+    pure = return+    (<*>) = ap+    {-# INLINE pure #-}+    {-# INLINE (<*>) #-}+instance Monad VGet where+    fail msg = VGet (\ _ -> return (VGetE msg))+    return r = VGet (\ s -> return (VGetR r s))+    m >>= k = VGet $ \ s ->+        _vget m s >>= \ c ->+        case c of+            VGetE msg -> return (VGetE msg)+            VGetR r s' -> _vget (k r) s'+    m >> k = VGet $ \ s ->+        _vget m s >>= \ c ->+        case c of+            VGetE msg -> return (VGetE msg)+            VGetR _ s' -> _vget k s'+    {-# INLINE fail #-}+    {-# INLINE return #-}+    {-# INLINE (>>=) #-}+    {-# INLINE (>>) #-}+instance Alternative VGet where+    empty = mzero+    (<|>) = mplus+    {-# INLINE empty #-}+    {-# INLINE (<|>) #-}+instance MonadPlus VGet where+    mzero = fail "mzero"+    mplus f g = VGet $ \ s ->+        _vget f s >>= \ c ->+        case c of+            VGetE _ -> _vget g s+            r -> return r+    {-# INLINE mzero #-}+    {-# INLINE mplus #-}+++-- | To be utilized with VCache, a value must be serializable as a +-- simple sequence of binary data and child VRefs. Also, to put then+-- get a value must result in equivalent values. Further, values are+-- Typeable to support memory caching of values loaded.+-- +-- Under the hood, structured data is serialized as the pair:+--+--    (ByteString,[Either VRef PVar])+--+-- Developers must ensure that `get` on the serialization from `put` +-- returns the same value. And `get` must be backwards compatible.+-- Developers should consider version wrappers, cf. SafeCopy package.+-- +class (Typeable a) => VCacheable a where +    -- | Serialize a value as a stream of bytes and value references. +    put :: a -> VPut ()++    -- | Parse a value from its serialized representation into memory.+    get :: VGet a+

@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}++module Database.VCache.VCacheable+    ( VCacheable(..)+    , module Database.VCache.VGet+    , module Database.VCache.VPut+    ) where++import Control.Applicative+import Control.Monad++import Data.Word+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++import Database.VCache.VGet+import Database.VCache.VPut+import Database.VCache.Types++-- VCacheable defined in Database.VCache.Types++instance VCacheable Int where+    get = fromIntegral <$> getVarInt+    put = putVarInt . fromIntegral+    {-# INLINE get #-}+    {-# INLINE put #-}++instance VCacheable Integer where+    get = getVarInt+    put = putVarInt+    {-# INLINE get #-}+    {-# INLINE put #-}++instance VCacheable Bool where+    get = getWord8 >>= \ n -> case n of+        0 -> return False+        1 -> return True+        _ -> fail "Boolean expects a 0 or 1 byte"+    put False = putWord8 0+    put True  = putWord8 1++instance VCacheable Char where +    get = getc+    put = putc+    {-# INLINE get #-}+    {-# INLINE put #-}++instance VCacheable Word8 where+    get = getWord8+    put = putWord8+    {-# INLINE get #-}+    {-# INLINE put #-}++instance VCacheable BS.ByteString where+    get = getVarNat >>= getByteString . fromIntegral+    put s = putVarNat (fromIntegral $ BS.length s) >> putByteString s +    {-# INLINE get #-}+    {-# INLINE put #-}++instance VCacheable LBS.ByteString where+    get = getVarNat >>= getByteStringLazy . fromIntegral+    put s = putVarNat (fromIntegral $ LBS.length s) >> putByteStringLazy s+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a) => VCacheable (VRef a) where+    get = getVRef+    put = putVRef+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a) => VCacheable (PVar a) where+    get = getPVar+    put = putPVar+    {-# INLINE get #-}+    {-# INLINE put #-}++-- unit is not actually serialized.+instance VCacheable () where+    get = return ()+    put () = return ()+    {-# INLINE get #-}+    {-# INLINE put #-}++-- `Maybe a` may be upgraded transparently to [a], and may share+-- structure with single element lists.+instance (VCacheable a) => VCacheable (Maybe a) where+    get = getWord8 >>= \ n -> case n of +        0 -> return Nothing+        1 -> Just <$> get+        _ -> fail "Type `Maybe a` expects prefix byte 0 or 1"+    put Nothing  = putWord8 0+    put (Just a) = putWord8 1 >> put a++instance (VCacheable a, VCacheable b) => VCacheable (Either a b) where+    get = getWord8 >>= \ lr -> case lr of+        0 -> Left <$> get+        1 -> Right <$> get+        _ -> fail "Type `Either a b` expects prefix byte 0 or 1"+    put (Left a) = putWord8 0 >> put a+    put (Right b) = putWord8 1 >> put b++-- NOTE: lists are stored in *reverse* order, such that when read+-- the nodes can be directly constructed into normal order without+-- reversing the list, i.e. thus optimizing for read.+instance (VCacheable a) => VCacheable [a] where+    get = do+        nCount <- liftM fromIntegral getVarNat+        replicateReversed [] nCount get+    put ls = do+        let (nCount, lsr) = countAndReverse ls+        putVarNat (fromIntegral nCount)+        mapM_ put lsr+    {-# INLINE get #-}+    {-# INLINE put #-}++-- replicate an operation and build a reversed list of results.+replicateReversed :: (Monad m) => [a] -> Int -> m a -> m [a]+replicateReversed xs 0 _ = return xs+replicateReversed xs n op = op >>= \ x -> replicateReversed (x:xs) (n-1) op++-- single pass to count and reverse list+countAndReverse :: [a] -> (Int, [a])+countAndReverse = cr [] 0 where+    cr l !n (x:xs) = cr (x:l) (n+1) xs+    cr l !n [] = (n, l)+++-- note that ((a,b),c) and (a,(b,c)) share serialized structure.+-- So does ((a,b),(c,d)) and (a,(b,c),d), etc.+instance (VCacheable a, VCacheable b) => VCacheable (a,b) where+    get = liftM2 (,) get get+    put (a,b) = do { put a; put b }+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a, VCacheable b, VCacheable c) => VCacheable (a,b,c) where+    get = liftM3 (,,) get get get+    put (a,b,c) = do { put a; put b; put c }+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a, VCacheable b, VCacheable c, VCacheable d) +    => VCacheable (a,b,c,d) where+    get = liftM4 (,,,) get get get get+    put (a,b,c,d) = do { put a; put b; put c; put d }+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a, VCacheable b, VCacheable c, VCacheable d, VCacheable e) +    => VCacheable (a,b,c,d,e) where+    get = liftM5 (,,,,) get get get get get+    put (a,b,c,d,e) = do { put a; put b; put c; put d; put e }+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a, VCacheable b, VCacheable c, VCacheable d, VCacheable e+         , VCacheable f) => VCacheable (a,b,c,d,e,f) where+    get = +        do a <- get; b <- get; c <- get+           d <- get; e <- get; f <- get+           return (a,b,c,d,e,f)+    put (a,b,c,d,e,f) = do { put a; put b; put c; put d; put e; put f }+    {-# INLINE get #-}+    {-# INLINE put #-}++instance (VCacheable a, VCacheable b, VCacheable c, VCacheable d, VCacheable e+         , VCacheable f, VCacheable g) => VCacheable (a,b,c,d,e,f,g) where+    get = +        do a <- get; b <- get; c <- get+           d <- get; e <- get; f <- get; g <- get+           return (a,b,c,d,e,f,g)+    put (a,b,c,d,e,f,g) = do { put a; put b; put c; put d; put e; put f; put g }+    {-# INLINE get #-}+    {-# INLINE put #-}++

@@ -0,0 +1,329 @@+{-# LANGUAGE BangPatterns #-}++module Database.VCache.VGet +    ( VGet++    -- * Prim Readers+    , getVRef, getPVar+    , getWord8+    , getWord16le, getWord16be+    , getWord32le, getWord32be+    , getWord64le, getWord64be+    , getStorable+    , getVarNat, getVarInt+    , getByteString, getByteStringLazy+    , getc++    -- * Parser Combinators+    , isolate+    , label+    , lookAhead, lookAheadM, lookAheadE+    , isEmpty++    ) where++import Control.Applicative++import Data.Bits+import Data.Char+import Data.Word+import Foreign.Ptr+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Alloc (mallocBytes,finalizerFree)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.ForeignPtr (newForeignPtr)++import qualified Data.List as L+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Lazy as LBS++import Database.VCache.Types+import Database.VCache.Aligned+import Database.VCache.Alloc+import Database.VCache.VGetAux ++-- | isolate a parser to a subset of bytes and value references. The+-- child parser must process its entire input (all bytes and values) +-- or will fail. If there is not enough available input to isolate, +-- this operation will fail. +--+--      isolate nBytes nVRefs operation+--+isolate :: Int -> Int -> VGet a -> VGet a+isolate nBytes nRefs op = VGet $ \ s ->+    let pF = vget_target s `plusPtr` nBytes in+    if (pF > vget_limit s) then return (VGetE "isolate: not enough data") else+    case takeExact nRefs (vget_children s) of+        Nothing -> return (VGetE "isolate: not enough children")+        Just (cs,cs') -> +            let s_isolated = s { vget_children = cs+                               , vget_limit  = pF+                               }+            in+            let s_postIsolate = s { vget_children = cs'+                                  , vget_target = pF+                                  }+            in+            _vget op s_isolated >>= \ r_isolated -> case r_isolated of+                VGetE emsg -> return (VGetE emsg)+                VGetR r s' ->+                    let bDone = vgetStateEmpty s' in+                    if bDone then return (VGetR r s_postIsolate) else+                    return (VGetE "isolate: did not parse all input")++-- take exactly the requested amount from a list, or return Nothing.+takeExact :: Int -> [a] -> Maybe ([a],[a])+takeExact = takeExact' [] +{-# INLINE takeExact #-}++takeExact' :: [a] -> Int -> [a] -> Maybe ([a],[a])+takeExact' l 0 r = Just (L.reverse l, r)+takeExact' l n (r:rs) = takeExact' (r:l) (n-1) rs+takeExact' _ _ _ = Nothing++-- | Load a VRef, just the reference rather than the content. User must+-- know the type of the value, since getVRef is essentially a typecast.+-- VRef content is not read until deref. +--+-- All instances of a VRef with the same type and address will share the+-- same cache.+getVRef :: (VCacheable a) => VGet (VRef a)+getVRef = VGet $ \ s -> +    case (vget_children s) of+        (c:cs) | isVRefAddr c -> do+            let s' = s { vget_children = cs }+            vref <- addr2vref (vget_space s) c+            return (VGetR vref s')+        _ -> return (VGetE "getVRef")+{-# INLINABLE getVRef #-}++-- | Load a PVar, just the variable. Content is loaded lazily on first+-- read, then kept in memory until the PVar is GC'd. Unlike other Haskell+-- variables, PVars can be serialized to the VCache address space. All +-- PVars for a specific address are collapsed, using the same TVar.+--+-- Developers must know the type of the PVar, since getPVar will cast to+-- any cacheable type. A runtime error is raised only if you attempt to+-- load the same PVar address with two different types.+--+getPVar :: (VCacheable a) => VGet (PVar a) +getPVar = VGet $ \ s ->+    case (vget_children s) of+        (c:cs) | isPVarAddr c -> do+            let s' = s { vget_children = cs }+            pvar <- addr2pvar (vget_space s) c+            return (VGetR pvar s')+        _ -> return (VGetE "getPVar")+{-# INLINABLE getPVar #-}++-- | Read words of size 16, 32, or 64 in little-endian or big-endian.+getWord16le, getWord16be :: VGet Word16+getWord32le, getWord32be :: VGet Word32+getWord64le, getWord64be :: VGet Word64++getWord16le = consuming 2 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    let r = (fromIntegral b1 `shiftL`  8) .|.+            (fromIntegral b0            )+    let s' = s { vget_target = p `plusPtr` 2 }+    return (VGetR r s')+{-# INLINE getWord16le #-}++getWord32le = consuming 4 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    b2 <- peekByte (p `plusPtr` 2)+    b3 <- peekByte (p `plusPtr` 3)+    let r = (fromIntegral b3 `shiftL` 24) .|.+            (fromIntegral b2 `shiftL` 16) .|.+            (fromIntegral b1 `shiftL`  8) .|.+            (fromIntegral b0            )+    let s' = s { vget_target = p `plusPtr` 4 }+    return (VGetR r s')+{-# INLINE getWord32le #-}++getWord64le = consuming 8 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    b2 <- peekByte (p `plusPtr` 2)+    b3 <- peekByte (p `plusPtr` 3)+    b4 <- peekByte (p `plusPtr` 4)+    b5 <- peekByte (p `plusPtr` 5)+    b6 <- peekByte (p `plusPtr` 6)+    b7 <- peekByte (p `plusPtr` 7)+    let r = (fromIntegral b7 `shiftL` 56) .|.+            (fromIntegral b6 `shiftL` 48) .|.+            (fromIntegral b5 `shiftL` 40) .|.+            (fromIntegral b4 `shiftL` 32) .|.+            (fromIntegral b3 `shiftL` 24) .|.+            (fromIntegral b2 `shiftL` 16) .|.+            (fromIntegral b1 `shiftL`  8) .|.+            (fromIntegral b0            )    +    let s' = s { vget_target = p `plusPtr` 8 }+    return (VGetR r s')+{-# INLINE getWord64le #-}++getWord16be = consuming 2 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    let r = (fromIntegral b0 `shiftL`  8) .|.+            (fromIntegral b1            )+    let s' = s { vget_target = p `plusPtr` 2 }+    return (VGetR r s')+{-# INLINE getWord16be #-}++getWord32be = consuming 4 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    b2 <- peekByte (p `plusPtr` 2)+    b3 <- peekByte (p `plusPtr` 3)+    let r = (fromIntegral b0 `shiftL` 24) .|.+            (fromIntegral b1 `shiftL` 16) .|.+            (fromIntegral b2 `shiftL`  8) .|.+            (fromIntegral b3            )+    let s' = s { vget_target = p `plusPtr` 4 }+    return (VGetR r s')+{-# INLINE getWord32be #-}++getWord64be = consuming 8 $ VGet $ \ s -> do+    let p = vget_target s+    b0 <- peekByte p+    b1 <- peekByte (p `plusPtr` 1)+    b2 <- peekByte (p `plusPtr` 2)+    b3 <- peekByte (p `plusPtr` 3)+    b4 <- peekByte (p `plusPtr` 4)+    b5 <- peekByte (p `plusPtr` 5)+    b6 <- peekByte (p `plusPtr` 6)+    b7 <- peekByte (p `plusPtr` 7)+    let r = (fromIntegral b0 `shiftL` 56) .|.+            (fromIntegral b1 `shiftL` 48) .|.+            (fromIntegral b2 `shiftL` 40) .|.+            (fromIntegral b3 `shiftL` 32) .|.+            (fromIntegral b4 `shiftL` 24) .|.+            (fromIntegral b5 `shiftL` 16) .|.+            (fromIntegral b6 `shiftL`  8) .|.+            (fromIntegral b7            )    +    let s' = s { vget_target = p `plusPtr` 8 }+    return (VGetR r s')+{-# INLINE getWord64be #-}++-- | Read a Storable value. In this case, the content should be+-- bytes only, since pointers aren't really meaningful when persisted.+-- Data is copied to an intermediate structure via alloca to avoid+-- alignment issues.+getStorable :: (Storable a) => VGet a+getStorable = _getStorable undefined+{-# INLINE getStorable #-}++_getStorable :: (Storable a) => a -> VGet a+_getStorable _dummy = +    let n = sizeOf _dummy in+    consuming n $ VGet $ \ s -> do+        let pTgt = vget_target s +        let s' = s { vget_target = pTgt `plusPtr` n }+        a <- peekAligned (castPtr pTgt)+        return (VGetR a s')+{-# INLINE _getStorable #-}++-- | Load a number of bytes from the underlying object. A copy is+-- performed in this case (typically no copy is performed by VGet,+-- but the underlying pointer is ephemeral, becoming invalid after+-- the current read transaction). Fails if not enough data. O(N)+getByteString :: Int -> VGet BS.ByteString+getByteString n | (n > 0)   = _getByteString n+                | otherwise = return (BS.empty)+{-# INLINE getByteString #-}++_getByteString :: Int -> VGet BS.ByteString+_getByteString n = consuming n $ VGet $ \ s -> do+    let pSrc = vget_target s+    pDst <- mallocBytes n+    copyBytes pDst pSrc n+    fp <- newForeignPtr finalizerFree pDst+    let r = BSI.fromForeignPtr fp 0 n+    let s' = s { vget_target = (pSrc `plusPtr` n) }+    return (VGetR r s')++-- | Get a lazy bytestring. (Simple wrapper on strict bytestring.)+getByteStringLazy :: Int -> VGet LBS.ByteString+getByteStringLazy n = LBS.fromStrict <$> getByteString n+{-# INLINE getByteStringLazy #-}+++-- | Get a character from UTF-8 format. Assumes a valid encoding.+-- (In case of invalid encoding, arbitrary characters may be returned.)+getc :: VGet Char+getc = +    _c0 >>= \ b0 ->+    if (b0 < 0x80) then return $! chr b0 else+    if (b0 < 0xe0) then _getc2 (b0 `xor` 0xc0) else+    if (b0 < 0xf0) then _getc3 (b0 `xor` 0xe0) else+    _getc4 (b0 `xor` 0xf0)++-- get UTF-8 of size 2,3,4 bytes+_getc2, _getc3, _getc4 :: Int -> VGet Char+_getc2 b0 =+    _cc >>= \ b1 ->+    return $! chr ((b0 `shiftL` 6) .|. b1)+_getc3 b0 =+    _cc >>= \ b1 ->+    _cc >>= \ b2 ->+    return $! chr ((b0 `shiftL` 12) .|. (b1 `shiftL` 6) .|. b2)+_getc4 b0 =+    _cc >>= \ b1 ->+    _cc >>= \ b2 ->+    _cc >>= \ b3 ->+    return $! chr ((b0 `shiftL` 18) .|. (b1 `shiftL` 12) .|. (b2 `shiftL` 6) .|. b3)++_c0,_cc :: VGet Int+_c0 = fromIntegral <$> getWord8+_cc = (fromIntegral . xor 0x80) <$> getWord8+{-# INLINE _c0 #-}+{-# INLINE _cc #-}++++-- | label will modify the error message returned from the+-- argument operation; it can help contextualize parse errors.+label :: ShowS -> VGet a -> VGet a+label sf op = VGet $ \ s ->+    _vget op s >>= \ r ->+    return $+    case r of+        VGetE emsg -> VGetE (sf emsg)+        ok@(VGetR _ _) -> ok++-- | lookAhead will parse a value, but not consume any input.+lookAhead :: VGet a -> VGet a+lookAhead op = VGet $ \ s ->+    _vget op s >>= \ result -> +    return $+    case result of+        VGetR r _ -> VGetR r s+        other -> other++-- | lookAheadM will consume input only if it returns `Just a`.+lookAheadM :: VGet (Maybe a) -> VGet (Maybe a)+lookAheadM op = VGet $ \ s ->+    _vget op s >>= \ result -> +    return $+    case result of+        VGetR Nothing _ -> VGetR Nothing s+        other -> other++-- | lookAheadE will consume input only if it returns `Right b`.+lookAheadE :: VGet (Either a b) -> VGet (Either a b)+lookAheadE op = VGet $ \ s ->+    _vget op s >>= \ result ->+    return $+    case result of+        VGetR l@(Left _) _ -> VGetR l s+        other -> other+

@@ -0,0 +1,98 @@+{-# LANGUAGE BangPatterns #-}+-- This module mostly exists to avoid cyclic dependencies+module Database.VCache.VGetAux +    ( getWord8FromEnd+    , getWord8+    , isEmpty, vgetStateEmpty+    , getVarNat+    , getVarInt+    , consuming+    , peekByte+    ) where++import Control.Applicative+import Data.Word+import Data.Bits+import qualified Data.List as L+import Foreign.Ptr+import Foreign.Storable+import Database.VCache.Types++-- | Read one byte of data, or fail if not enough data.+getWord8 :: VGet Word8 +getWord8 = consuming 1 $ VGet $ \ s -> do+    let p = vget_target s+    r <- peekByte p+    let s' = s { vget_target = p `plusPtr` 1 }+    return (VGetR r s')+{-# INLINE getWord8 #-}++getWord8FromEnd :: VGet Word8+getWord8FromEnd = consuming 1 $ VGet $ \ s -> do+    let p = vget_limit s `plusPtr` (-1)+    r <- peekByte p+    let s' = s { vget_limit = p }+    return (VGetR r s')+{-# INLINE getWord8FromEnd #-}++-- to simplify type inference+peekByte :: Ptr Word8 -> IO Word8+peekByte = peek+{-# INLINE peekByte #-}++-- | isEmpty will return True iff there is no available input (neither+-- references nor values).+isEmpty :: VGet Bool+isEmpty = VGet $ \ s ->+    let bEOF = vgetStateEmpty s in+    bEOF `seq` return (VGetR bEOF s)+{-# INLINE isEmpty #-}++vgetStateEmpty :: VGetS -> Bool+vgetStateEmpty s = (vget_target s == vget_limit s)+                && (L.null (vget_children s))+{-# INLINE vgetStateEmpty #-}++-- | Get an integer represented in the Google protocol buffers zigzag+-- 'varint' encoding, e.g. as produced by 'putVarInt'. +getVarInt :: VGet Integer+getVarInt = unZigZag <$> getVarNat+{-# INLINE getVarInt #-}++-- undo protocol buffers zigzag encoding+unZigZag :: Integer -> Integer+unZigZag !n =+    let (q,r) = n `divMod` 2 in+    if (1 == r) then negate q - 1+                else q+{-# INLINE unZigZag #-}++-- | Get a non-negative number represented in the Google protocol+-- buffers 'varint' encoding, e.g. as produced by 'putVarNat'.+getVarNat :: VGet Integer+getVarNat = getVarNat' 0+{-# INLINE getVarNat #-}++-- getVarNat' uses accumulator+getVarNat' :: Integer -> VGet Integer+getVarNat' !n =+    getWord8 >>= \ w ->+    let n' = (128 * n) + fromIntegral (w .&. 0x7f) in+    if (w < 128) then return $! n'+                 else getVarNat' n'+++-- consuming a number of bytes (for unsafe VGet operations)+--  does not perform a full isolation+consuming :: Int -> VGet a -> VGet a+consuming n op = VGet $ \ s ->+    let pConsuming = vget_target s `plusPtr` n in+    if (pConsuming > vget_limit s) then return (VGetE "not enough data") else +    _vget op s +{-# RULES+"consuming.consuming"   forall n1 n2 op . consuming n1 (consuming n2 op) = consuming (max n1 n2) op+"consuming>>consuming"  forall n1 n2 f g . consuming n1 f >> consuming n2 g = consuming (n1+n2) (f>>g)+"consuming>>=consuming" forall n1 n2 f g . consuming n1 f >>= consuming n2 . g = consuming (n1+n2) (f>>=g)+ #-}+{-# INLINABLE consuming #-}+

@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module Database.VCache.VGetInit+    ( vgetInit+    ) where++import Data.Bits+import Foreign.Ptr+import Database.VCache.Types+import Database.VCache.VGetAux++-- | For VGet from the database, we start with just a pointer and a+-- size. To process the VGet data, we also need to read addresses +-- from a dedicated region. This is encoded from the end, as follows:+--+--     (normal data) addressN offset offset offset offset ... bytes+--                                                           +-- Here 'bytes' is basically a varNat encoded backwards for the+-- number of bytes (not counting 'bytes') back to the start of the+-- first address. This address is then encoded as a varNat, and any+-- offset is encoded as a varInt with the idea of reducing overhead+-- for encoding addresses near to each other in memory.+--+-- Addresses are encoded such that the first address to parse is last+-- in the sequence (thereby avoiding a list reverse operation).+--+-- To read addresses, we simply read the number of bytes from the end,+-- step back that far, then read the initial address and offsets until+-- we get back to the end. This must be performed before we apply the+-- normal read operation for the VGet state. It must be applied exactly+-- once for a given input.+--+vgetInit :: VGet ()+vgetInit =+    readAddrBytes >>= \ nAddrBytes ->+    if (0 == nAddrBytes) then return () else+    VGet $ \ s -> +        let bUnderflow = nAddrBytes > (vget_limit s `minusPtr` vget_target s) in +        if bUnderflow then return eBadAddressRegion else +        let pAddrs = vget_limit s `plusPtr` negate nAddrBytes in+        let sAddrs = s { vget_target = pAddrs } in+        _vget readAddrs sAddrs >>= \ mbAddrs ->+        case mbAddrs of+            VGetR addrs _ ->+                let s' = s { vget_children = addrs, vget_limit = pAddrs } in+                return (VGetR () s')+            VGetE eMsg -> return (VGetE eMsg)+{-# INLINABLE vgetInit #-}++eBadAddressRegion :: VGetR a+eBadAddressRegion = VGetE "VGet: failed to read address region"++readAddrBytes :: VGet Int+readAddrBytes = readAddrBytes' 0+{-# INLINE readAddrBytes #-}++readAddrBytes' :: Int -> VGet Int+readAddrBytes' !nAccum = +    getWord8FromEnd >>= \ w8 ->+    let nAccum' = (nAccum `shiftL` 7) .|. (fromIntegral (0x7f .&. w8)) in+    if (w8 < 0x80) then return $! nAccum' else+    readAddrBytes' nAccum'++-- read a variable list of at least one address+readAddrs :: VGet [Address]+readAddrs = +    getVarNat >>= \ nFirst ->+    let addr0 = fromIntegral nFirst in+    addr0 `seq` readAddrs' [addr0] nFirst++-- read address offsets until end of input+readAddrs' :: [Address] -> Integer -> VGet [Address]+readAddrs' addrs !nLast =+    isEmpty >>= \ bEmpty ->+    if bEmpty then return addrs else+    getVarInt >>= \ nOff ->+    let nCurr = nLast + nOff in+    let addr = fromIntegral nCurr in+    addr `seq` readAddrs' (addr:addrs) nCurr+

@@ -0,0 +1,224 @@++++module Database.VCache.VPut+    ( VPut++    -- * Prim Writers+    , putVRef, putPVar+    , putWord8+    , putWord16le, putWord16be+    , putWord32le, putWord32be+    , putWord64le, putWord64be+    , putStorable+    , putVarNat, putVarInt+    , reserve, reserving, unsafePutWord8+    , putByteString, putByteStringLazy+    , putc+    ) where++import Data.Bits+import Data.Char+import Data.Word+import Foreign.Ptr (plusPtr,castPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Utils (copyBytes)+import Foreign.ForeignPtr (withForeignPtr)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Lazy as LBS++import Database.VCache.Types+import Database.VCache.Aligned+import Database.VCache.VPutAux+-- import Database.VCache.Impl++-- | Store a reference to a value. The value reference must already+-- use the same VCache and addres space as where you're putting it.+putVRef :: VRef a -> VPut ()+putVRef ref = VPut $ \ s ->+    if (vput_space s == vref_space ref) then _putVRef s ref else+    fail $ "putVRef argument is not from destination VCache" +{-# INLINABLE putVRef #-}++-- assuming destination and ref have same address space+_putVRef :: VPutS -> VRef a -> IO (VPutR ())+_putVRef s ref = +    let cs = vput_children s in+    let c  = PutChild (Right ref) in+    let s' = s { vput_children = (c:cs) } in+    return (VPutR () s')+{-# INLINE _putVRef #-}++-- | Store an identifier for a persistent variable in the same VCache+-- and address space.+putPVar :: PVar a -> VPut ()+putPVar pvar = VPut $ \ s ->+    if (vput_space s == pvar_space pvar) then _putPVar s pvar else +    fail $ "putPVar argument is not from destination VCache"+{-# INLINABLE putPVar #-}++-- assuming destination and var have same address space+_putPVar :: VPutS -> PVar a -> IO (VPutR ())+_putPVar s pvar = +    let cs = vput_children s in+    let c  = PutChild (Left pvar) in+    let s' = s { vput_children = (c:cs) } in+    return (VPutR () s')+{-# INLINE _putPVar #-}++-- | Put a Word in little-endian or big-endian form.+--+-- Note: These are mostly included because they're part of the +-- Data.Binary and Data.Cereal APIs. They may be useful in some+-- cases, but putVarInt will frequently be preferable.+putWord16le, putWord16be :: Word16 -> VPut ()+putWord32le, putWord32be :: Word32 -> VPut ()+putWord64le, putWord64be :: Word64 -> VPut ()++-- THOUGHTS: I could probably optimize these further by using+-- an intermediate type and some rewriting to combine reserve+-- operations. However, I doubt I'll actually use putWord* all+-- that much... mostly just including to match the Data.Cereal+-- and Data.Binary APIs. I expect to use variable-sized integers+-- and such much more frequently.+++putWord16le w = reserving 2 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 2) }+    poke (p            ) (fromIntegral (w           ) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 8) :: Word8)+    return (VPutR () s')+{-# INLINE putWord16le #-}++putWord32le w = reserving 4 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 4) }+    poke (p            ) (fromIntegral (w            ) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w `shiftR`  8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 16) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 24) :: Word8)+    return (VPutR () s')+{-# INLINE putWord32le #-}++putWord64le w = reserving 8 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 8) }+    poke (p            ) (fromIntegral (w            ) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w `shiftR`  8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 16) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 24) :: Word8)+    poke (p `plusPtr` 4) (fromIntegral (w `shiftR` 32) :: Word8)+    poke (p `plusPtr` 5) (fromIntegral (w `shiftR` 40) :: Word8)+    poke (p `plusPtr` 6) (fromIntegral (w `shiftR` 48) :: Word8)+    poke (p `plusPtr` 7) (fromIntegral (w `shiftR` 56) :: Word8)+    return (VPutR () s')+{-# INLINE putWord64le #-}++putWord16be w = reserving 2 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 2) }+    poke (p            ) (fromIntegral (w `shiftR` 8) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w           ) :: Word8)+    return (VPutR () s')+{-# INLINE putWord16be #-}++putWord32be w = reserving 4 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 4) }+    poke (p            ) (fromIntegral (w `shiftR` 24) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 16) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (w `shiftR`  8) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (w            ) :: Word8)+    return (VPutR () s')+{-# INLINE putWord32be #-}++putWord64be w = reserving 8 $ VPut $ \ s -> do+    let p = vput_target s+    let s' = s { vput_target = (p `plusPtr` 8) }+    poke (p            ) (fromIntegral (w `shiftR` 56) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 48) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 40) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 32) :: Word8)+    poke (p `plusPtr` 4) (fromIntegral (w `shiftR` 24) :: Word8)+    poke (p `plusPtr` 5) (fromIntegral (w `shiftR` 16) :: Word8)+    poke (p `plusPtr` 6) (fromIntegral (w `shiftR`  8) :: Word8)+    poke (p `plusPtr` 7) (fromIntegral (w            ) :: Word8)+    return (VPutR () s')+{-# INLINE putWord64be #-}++-- | Put a Data.Storable value, using intermediate storage to+-- ensure alignment when serializing argument. Note that this+-- shouldn't have any pointers, since serialized pointers won't+-- usually be valid when loaded later. Also, the storable type+-- shouldn't have any gaps (unassigned bytes); uninitialized+-- bytes may interfere with structure sharing in VCache.+putStorable :: (Storable a) => a -> VPut () +putStorable a = +    let n = sizeOf a in+    reserving n $ VPut $ \ s -> do+        let pTgt = vput_target s +        let s' = s { vput_target = (pTgt `plusPtr` n) } +        pokeAligned (castPtr pTgt) a+        return (VPutR () s')+{-# INLINABLE putStorable #-}++-- | Put the contents of a bytestring directly. Unlike the 'put' method for+-- bytestrings, this does not include size information; just raw bytes.+putByteString :: BS.ByteString -> VPut ()+putByteString s = reserving (BS.length s) (_putByteString s)+{-# INLINE putByteString #-}++-- | Put contents of a lazy bytestring directly. Unlike the 'put' method for+-- bytestrings, this does not include size information; just raw bytes.+putByteStringLazy :: LBS.ByteString -> VPut ()+putByteStringLazy s = reserving (fromIntegral $ LBS.length s) (mapM_ _putByteString (LBS.toChunks s))+{-# INLINE putByteStringLazy #-}++-- put a byte string, assuming enough space has been reserved already.+-- this uses a simple memcpy to the target space.+_putByteString :: BS.ByteString -> VPut ()+_putByteString (BSI.PS fpSrc p_off p_len) = +    VPut $ \ s -> withForeignPtr fpSrc $ \ pSrc -> do+        let pDst = vput_target s+        copyBytes pDst (pSrc `plusPtr` p_off) p_len+        let s' = s { vput_target = (pDst `plusPtr` p_len) }+        return (VPutR () s')+{-# INLINABLE _putByteString #-}++-- | Put a character in UTF-8 format.+putc :: Char -> VPut ()+putc a | c <= 0x7f      = putWord8 (fromIntegral c)+       | c <= 0x7ff     = reserving 2 $ VPut $ \ s -> do+                            let p  = vput_target s+                            let s' = s { vput_target = (p `plusPtr` 2) } +                            poke (p            ) (0xc0 .|. y)+                            poke (p `plusPtr` 1) (0x80 .|. z)+                            return (VPutR () s')+       | c <= 0xffff    = reserving 3 $ VPut $ \ s -> do+                            let p  = vput_target s+                            let s' = s { vput_target = (p `plusPtr` 3) }+                            poke (p            ) (0xe0 .|. x)+                            poke (p `plusPtr` 1) (0x80 .|. y)+                            poke (p `plusPtr` 2) (0x80 .|. z)+                            return (VPutR () s')+       | c <= 0x10ffff  = reserving 4 $ VPut $ \ s -> do+                            let p = vput_target s+                            let s' = s { vput_target = (p `plusPtr` 4) }+                            poke (p            ) (0xf0 .|. w)+                            poke (p `plusPtr` 1) (0x80 .|. x)+                            poke (p `plusPtr` 2) (0x80 .|. y)+                            poke (p `plusPtr` 3) (0x80 .|. z)+                            return (VPutR () s')+        | otherwise     = fail "not a valid character" -- shouldn't happen+    where +        c = ord a+        z, y, x, w :: Word8+        z = fromIntegral (c           .&. 0x3f)+        y = fromIntegral (shiftR c 6  .&. 0x3f)+        x = fromIntegral (shiftR c 12 .&. 0x3f)+        w = fromIntegral (shiftR c 18 .&. 0x7)++

@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}++-- dependencies of both VPutFini and VPut+module Database.VCache.VPutAux+    ( reserving, reserve+    , unsafePutWord8+    , putWord8+    , putVarNat+    , putVarInt+    , putVarNatR+    ) where++import Control.Applicative+import Data.Bits+import Data.Word+import Data.IORef+import Foreign.Storable+import Foreign.Ptr+import Foreign.Marshal.Alloc++import Database.VCache.Types+++reserving :: Int -> VPut a -> VPut a+reserving n op = reserve n >> op+{-# RULES+"reserving >> reserving" forall n1 n2 f g . reserving n1 f >> reserving n2 g = reserving (n1+n2) (f>>g)+ #-}+{-# INLINABLE reserving #-}++-- | Ensure that at least N bytes are available for storage without+-- growing the underlying buffer. Use this before unsafePutWord8 +-- and similar operations. If the buffer must grow, it will grow+-- exponentially to ensure amortized constant allocation costs.+reserve :: Int -> VPut ()+reserve n = VPut $ \ s ->+    let avail = vput_limit s `minusPtr` vput_target s in+    if (avail >= n) then return (VPutR () s) +                    else VPutR () <$> grow n s +{-# INLINE reserve #-}++grow :: Int -> VPutS -> IO VPutS+grow n s =+    readIORef (vput_buffer s) >>= \ pBuff ->+    let currSize = vput_limit s `minusPtr` pBuff in+    let bytesUsed = vput_target s `minusPtr` pBuff in+    -- heuristic exponential growth+    let bytesNeeded = (2 * currSize) + n + 1000 in +    reallocBytes pBuff bytesNeeded >>= \ pBuff' ->+    -- (realloc will throw if it fails)+    writeIORef (vput_buffer s) pBuff' >>+    let target' = pBuff' `plusPtr` bytesUsed in+    let limit' = pBuff' `plusPtr` bytesNeeded in+    return $ s+        { vput_target = target'+        , vput_limit = limit'+        }+{-# NOINLINE grow #-}++-- | Store an 8 bit word *assuming* enough space has been reserved.+-- This can be used safely together with 'reserve'.+unsafePutWord8 :: Word8 -> VPut ()+unsafePutWord8 w8 = VPut $ \ s -> +    let pTgt = vput_target s in+    let s' = s { vput_target = (pTgt `plusPtr` 1) } in+    poke pTgt w8 >>+    return (VPutR () s')+{-# INLINE unsafePutWord8 #-}++-- | Store an 8 bit word.+putWord8 :: Word8 -> VPut ()+putWord8 w8 = reserving 1 $ unsafePutWord8 w8+{-# INLINE putWord8 #-}++-- | Put an arbitrary non-negative integer in 'varint' format associated+-- with Google protocol buffers. This takes one byte for values 0..127,+-- two bytes for 128..16k, etc.. Will fail if given a negative argument.+putVarNat :: Integer -> VPut ()+putVarNat n | (n < 0) = fail $ "putVarNat with " ++ show n+            | otherwise = _putVarNat q >> putWord8 bLo +  where q   = n `shiftR` 7+        bLo = 0x7f .&. fromIntegral n++_putVarNat :: Integer -> VPut ()+_putVarNat 0 = return ()+_putVarNat n = _putVarNat q >> putWord8 b where+    q = n `shiftR` 7+    b = 0x80 .|. (0x7f .&. fromIntegral n)++-- | Put an arbitrary integer in a 'varint' format associated with+-- Google protocol buffers with zigzag encoding of negative numbers.+-- This takes one byte for values -64..63, two bytes for -8k..8k, +-- three bytes for -1M..1M, etc.. Very useful if most numbers are+-- near 0.+putVarInt :: Integer -> VPut ()+putVarInt = putVarNat . zigZag+{-# INLINE putVarInt #-}++zigZag :: Integer -> Integer+zigZag n | (n < 0)   = (negate n * 2) - 1+         | otherwise = (n * 2)+{-# INLINE zigZag #-}+++-- | write a varNat, but reversed (i.e. little-endian)+--+-- This is only used by VPutFini: the last entry is the size (in bytes)+-- of the children list. But we write backwards so we can later read it+-- from the end of the buffer.+putVarNatR :: Int -> VPut ()+putVarNatR n | (n < 0) = fail $ "putVarNatR with " ++ show n +             | otherwise = putWord8 bLo >> _putVarNatR q +  where bLo  = 0x7f .&. fromIntegral n+        q    = n `shiftR` 7++_putVarNatR :: Int -> VPut () +_putVarNatR 0 = return ()+_putVarNatR n = putWord8 b >> _putVarNatR q where+    b = 0x80 .|. (0x7f .&. fromIntegral n)+    q = n `shiftR` 7

@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}++module Database.VCache.VPutFini+    ( vputFini+    , runVPutIO+    , runVPut+    ) where++import Control.Exception (onException)+import Data.IORef+import Data.ByteString (ByteString)+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.ByteString.Internal as BSI++import Database.VCache.Types+import Database.VCache.VPutAux++-- | When we're just about done with VPut, we really have one more+-- task to perform: to output the address list for any contained +-- PVars and VRefs. These addresses are simply concatenated onto the+-- normal byte output, with a final size value (not including itself)+-- to indicate how far to jump back.+--+-- Actually, we output the first address followed by relative offsets+-- for every following address. This behavior allows us to reduce the+-- serialization costs when addresses are near each other in memory.+--+-- The address list is output in the reverse order of serialization.+-- (This simplifies reading in the same order as serialization without+-- a list reversal operation.)+--+-- It's important that we finalize exactly once for every serialization,+-- and that this be applied before any hash functions.+vputFini :: VPut ()+vputFini = do+    szStart <- getBufferSize+    lChildren <- listChildren+    putChildren lChildren+    szFini <- getBufferSize+    putVarNatR (szFini - szStart)+    -- shrinkBuffer++getBufferSize :: VPut Int+getBufferSize = VPut $ \ s ->+    readIORef (vput_buffer s) >>= \ pStart ->+    let size = (vput_target s) `minusPtr` pStart in+    size `seq`+    return (VPutR size s)+{-# INLINE getBufferSize #-}++listChildren :: VPut [PutChild]+listChildren = VPut $ \ s ->+    let r = vput_children s in+    return (VPutR r s)+{-# INLINE listChildren #-}++putChildren :: [PutChild] -> VPut ()+putChildren [] = return ()+putChildren (x:xs) = +    let addr0 = putChildAddr x in+    putVarNat (fromIntegral addr0) >>+    putChildren' addr0 xs++-- putChildren after the first, using offsets.+putChildren' :: Address -> [PutChild] -> VPut ()+putChildren' _ [] = return ()+putChildren' !prev (x:xs) = +    let addrX = putChildAddr x in+    let offset = (fromIntegral addrX) - (fromIntegral prev) in+    putVarInt offset >>+    putChildren' addrX xs++runVPutIO :: VSpace -> VPut a -> IO (a, ByteString, [PutChild])+runVPutIO vs action = do+    let initialSize = 1000 -- avoid reallocs for small data+    pBuff <- mallocBytes initialSize+    vBuff <- newIORef pBuff+    let s0 = VPutS { vput_space = vs+                   , vput_children = []+                   , vput_buffer = vBuff+                   , vput_target = pBuff+                   , vput_limit = pBuff `plusPtr` initialSize+                   }+    let freeBuff = readIORef vBuff >>= free+    let fullWrite = do { result <- action; vputFini; return result }+    let runPut = _vput fullWrite s0+    (VPutR r sf) <- runPut `onException` freeBuff+    pBuff' <- readIORef vBuff+    let len = vput_target sf `minusPtr` pBuff'+    pBuffR <- reallocBytes pBuff len -- reclaim unused space+    fpBuff' <- newForeignPtr finalizerFree pBuffR+    let bytes = BSI.fromForeignPtr fpBuff' 0 len+    return (r, bytes, vput_children sf)+{-# NOINLINE runVPutIO #-}++runVPut :: VSpace -> VPut a -> (a, ByteString, [PutChild])+runVPut vs action = unsafePerformIO (runVPutIO vs action)+

@@ -0,0 +1,123 @@+++module Database.VCache.VRef+    ( VRef+    , vref, deref+    , vref', deref'+    , unsafeVRefAddr+    , unsafeVRefRefct+    , vref_space+    , CacheMode(..)+    , vrefc, derefc+    ) where++import Control.Monad+import Data.IORef+import System.IO.Unsafe +import Database.VCache.Types+import Database.VCache.Alloc+import Database.VCache.Read++-- | Construct a reference with the cache initially active, i.e.+-- such that immediate deref can access the value without reading+-- from the database. The given value will be placed in the cache+-- unless the same vref has already been constructed.+vref :: (VCacheable a) => VSpace -> a -> VRef a+vref = vrefc CacheMode1 +{-# INLINE vref #-}++-- | Construct a VRef with an alternative cache control mode. +vrefc :: (VCacheable a) => CacheMode -> VSpace -> a -> VRef a+vrefc cm vc v = unsafePerformIO (newVRefIO vc v cm)+{-# INLINABLE vrefc #-}++-- | In some cases, developers can reasonably assume they won't need a +-- value in the near future. In these cases, use the vref' constructor+-- to allocate a VRef without caching the content. +vref' :: (VCacheable a) => VSpace -> a -> VRef a+vref' vc v = unsafePerformIO (newVRefIO' vc v)+{-# INLINABLE vref' #-}++readVRef :: VRef a -> IO (a, Int)+readVRef v = readAddrIO (vref_space v) (vref_addr v) (vref_parse v)+{-# INLINE readVRef #-}++-- | Dereference a VRef, obtaining its value. If the value is not in+-- cache, it will be read into the database then cached. Otherwise, +-- the value is read from cache and the cache is touched to restart+-- any expiration.+--+-- Assuming a valid VCacheable instance, this operation should return+-- an equivalent value as was used to construct the VRef.+deref :: VRef a -> a+deref = derefc CacheMode1+{-# INLINE deref #-}++-- | Dereference a VRef with an alternative cache control mode.+derefc :: CacheMode -> VRef a -> a+derefc cm v = unsafeDupablePerformIO $ +    unsafeInterleaveIO (readVRef v) >>= \ lazy_read_rw ->+    join $ atomicModifyIORef (vref_cache v) $ \ c -> case c of+        Cached r bf ->+            let bf' = touchCache cm bf in+            let c' = Cached r bf' in+            (c', c' `seq` return r)+        NotCached ->+            let (r,w) = lazy_read_rw in+            let c' = mkVRefCache r w cm in+            let op = initVRefCache v >> return r in+            (c', c' `seq` op)+{-# NOINLINE derefc #-}+++-- I've modified how VRefs are recorded +++-- | Dereference a VRef. This will read from the cache if the value+-- is available, but will not update the cache. If the value is not+-- cached, it will be read instead from the persistence layer.+--+-- This can be useful if you know you'll only dereference a value +-- once for a given task, or if the datatype involved is cheap to+-- parse (e.g. simple bytestrings) such that there isn't a strong+-- need to cache the parse result.+deref' :: VRef a -> a+deref' v = unsafePerformIO $ +    readIORef (vref_cache v) >>= \ c -> case c of+        Cached r _ -> return r+        NotCached -> liftM fst (readVRef v)+{-# INLINABLE deref' #-}++-- | Each VRef has an numeric address in the VSpace. This address is+-- non-deterministic, and essentially independent of the arguments to+-- the vref constructor. This function is 'unsafe' in the sense that+-- it violates the illusion of purity. However, the VRef address will+-- be stable so long as the developer can guarantee it is reachable.+--+-- This function may be useful for memoization tables and similar.+--+-- The 'Show' instance for VRef will also show the address.+unsafeVRefAddr :: VRef a -> Address+unsafeVRefAddr = vref_addr+{-# INLINE unsafeVRefAddr #-}++-- | This function allows developers to access the reference count +-- for the VRef that is currently recorded in the database. This may+-- be useful for heuristic purposes. However, caveats are needed:+--+-- First, due to structure sharing, a VRef may share an address with+-- VRefs of other types having the same serialized form. Reference +-- counts are at the address level.+--+-- Second, because the VCache writer operates in a background thread,+-- the reference count returned here may be slightly out of date.+--+-- Third, it is possible that VCache will eventually use some other+-- form of garbage collection than reference counting. This function+-- should be considered an unstable element of the API.+unsafeVRefRefct :: VRef a -> IO Int+unsafeVRefRefct v = readRefctIO (vref_space v) (vref_addr v) +{-# INLINE unsafeVRefRefct #-}+++

@@ -0,0 +1,86 @@++module Database.VCache.VTx+    ( VTx+    , runVTx+    , liftSTM+    , markDurable+    , markDurableIf+    , getVTxSpace+    ) where++import Control.Monad +import Control.Monad.Trans.State.Strict+import Control.Concurrent.STM+import Control.Concurrent.MVar+import qualified Data.Map.Strict as Map+import Database.VCache.Types++-- | runVTx executes a transaction that may involve both STM TVars+-- (via liftSTM) and VCache PVars (via readPVar, writePVar). +runVTx :: VSpace -> VTx a -> IO a+runVTx vc action = do+    mvWait <- newEmptyMVar+    join (atomically (runVTx' vc mvWait action))+{-# INLINABLE runVTx #-}++runVTx' :: VSpace -> MVar () -> VTx a -> STM (IO a)+runVTx' vc mvWait action = +    let s0 = VTxState vc Map.empty False in+    runStateT (_vtx action) s0 >>= \ (r,s) ->+    -- fast path for read-only, non-durable actions+    let bWrite = not (Map.null (vtx_writes s)) in+    let bSync = vtx_durable s in+    let bDone = not (bWrite || bSync) in+    if bDone then return (return r) else+    -- otherwise, we update shared queue w/ potential conflicts+    readTVar (vcache_writes vc) >>= \ w ->+    let wdata' = updateLog (vtx_writes s) (write_data w) in+    let wsync' = updateSync bSync mvWait (write_sync w) in+    let w' = Writes { write_data = wdata', write_sync = wsync' } in+    writeTVar (vcache_writes vc) w' >>= \ () ->+    return $ w' `seq` do+        signalWriter vc +        when bSync (takeMVar mvWait)+        return r++-- Signal the writer of work to do.+signalWriter :: VSpace  -> IO ()+signalWriter vc = void (tryPutMVar (vcache_signal vc) ())+{-# INLINE signalWriter #-}++-- Record recent writes for each PVar.+updateLog :: WriteLog -> WriteLog -> WriteLog+updateLog updates writeLog = Map.union updates writeLog +{-# INLINE updateLog #-}++-- Track which threads are waiting on a commit signal.+updateSync :: Bool -> MVar () -> [MVar ()] -> [MVar ()]+updateSync bSync v = if bSync then (v:) else id+{-# INLINE updateSync #-}++-- | Durability for a VTx transaction is optional: it requires an+-- additional wait for the background thread to signal that it has+-- committed content to the persistence layer. Due to how writes +-- are batched, a durable transaction may share its wait with many+-- other transactions that occur at more or less the same time.+-- +-- Developers should mark a transaction durable only if necessary+-- based on domain layer policies. E.g. for a shopping service, +-- normal updates and views of the virtual shopping cart might not+-- be durable while committing to a purchase is durable. +--+markDurable :: VTx ()+markDurable = VTx $ modify $ \ vtx -> +    vtx { vtx_durable = True }+{-# INLINE markDurable #-}++-- | This variation of markDurable makes it easier to short-circuit+-- complex computations to decide durability when the transaction is+-- already durable. If durability is already marked, the boolean is+-- not evaluated.+markDurableIf :: Bool -> VTx ()+markDurableIf b = VTx $ modify $ \ vtx -> +    let bDurable = vtx_durable vtx || b in+    vtx { vtx_durable = bDurable }+{-# INLINE markDurableIf #-}+

@@ -0,0 +1,494 @@+{-# LANGUAGE BangPatterns #-}++-- Implementation of the Writer threads.+--+-- Some general design goals here:+--+--   Favor sequential processing (not random access)+--   Single read/write pass per database per frame+--   Append newly written content when possible+--+-- An exception to the single pass is the db_refct0 table, for which+-- I'll make a few passes. However, assuming GC is working, db_refct0+-- should be smaller than the in-memory ephemeron tables. So this +-- should not create any significant paging burden.+--+-- The writer handles GC to simplify reasoning about concurrency, in+-- particular the arbitration between reviving VRef addresses via the+-- structure sharing feature and deleting VRef addresses with zero+-- references. GC is incremental to avoid latency spikes with durable+-- transactions.+-- +module Database.VCache.Write+    ( writeStep+    ) where++import Control.Monad+import Control.Exception+import Control.Concurrent+import Control.Concurrent.STM+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.List as L+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc++import Database.LMDB.Raw+import Database.VCache.Types +import Database.VCache.VPutFini -- serialize updated PVars+import Database.VCache.VGetInit -- read dependencies to manage refcts+import Database.VCache.RWLock -- need a writer lock+import Database.VCache.Refct  -- to update reference counts+import Database.VCache.Hash   -- for GC of VRefs+import Database.VCache.Aligned++-- | when processing write batches, we'll need to track+-- differences in reference counts for each address.+--+-- For deletions, I'll use minBound as a simple sentinel.+type RefctDiff = Map Address Refct++-- A batch of updates to perform on memory, including dependencies+-- to incref. +--+-- Note: if a WriteCell has a null ByteString, this means we'll delete+-- the content. Empty bytestring is impossible as output from VPut+-- because we have at least a size for the child list.+type WriteBatch = Map Address WriteCell+type WriteCell = (ByteString, [PutChild])+type GCBatch = WriteBatch++-- for updating secondary indices, track names to addresses +type UpdSeek = Map ByteString [Address]++addrSize :: Int+addrSize = sizeOf (undefined :: Address)++-- Single step for VCache writer.+writeStep :: VSpace -> IO ()+writeStep vc = withRWLock (vcache_rwlock vc) $ do+    takeMVar (vcache_signal vc) ++    -- acquire writes, allocations, GC for this step+    ws <- atomically (takeWrites (vcache_writes vc))+    wb <- seralizeWrites (write_data ws)+    afrm <- allocFrameStep vc+    let allocInit = alloc_init afrm +    let ab = fmap fnWriteAlloc (alloc_list afrm) -- alloc batch+    let ub = Map.union wb ab                     -- update batch (favor writes)++    -- LMDB-layer read-write transaction.+    txn <- mdb_txn_begin (vcache_db_env vc) Nothing False++    -- select addresses for garbage collection +    let gcLimit = 1000 + 2 * Map.size ub -- adaptive GC rate+    gcb <- runGarbageCollector vc txn gcLimit++    -- update the db_memory. allocs, writes, deletes.+    let fb = Map.union gcb ub -- full batch+    let bUpdGCSep = Map.size fb == (Map.size ub + Map.size gcb) +    unless bUpdGCSep (fail "VCache bug: overlapping GC and update targets")+    (UpdateNotes rcDiff hsDel) <- updateVirtualMemory vc txn allocInit fb++    -- Update reference counts, +1 for new roots.+    let rcAlloc = fmap (\ an -> if isNewRoot an then 1 else 0) (alloc_list afrm)+    let rcUpd = Map.unionWith (\ a b -> (a + b)) rcDiff rcAlloc +    updateReferenceCounts vc txn allocInit rcUpd++    -- Update secondary indices: PVar roots, VRef hashes.+    let hsAlloc = fmap (fmap alloc_addr) (alloc_seek afrm)+    let hsUpd = Map.unionWith (++) hsDel hsAlloc +    writeSecondaryIndexes vc txn allocInit hsUpd++    -- Finish writeStep: commit, synch, stats, signals.+    mdb_txn_commit txn -- LMDB commit & synch+    modifyIORef' (vcache_gc_count vc) (+ (Map.size gcb)) -- update GC count+    vcache_signal_writes vc ws -- report write stats+    mapM_ syncSignal (write_sync ws) -- signal waiting threads+{-# NOINLINE writeStep #-}++-- Interact with GC and Allocation. Only safe once per writeStep.+allocFrameStep :: VSpace -> IO AllocFrame+allocFrameStep vc = modifyMVarMasked (vcache_memory vc) $ \ m -> do+    let ac = mem_alloc m+    let addr = alloc_new_addr ac+    let ac' = Allocator+            { alloc_new_addr = addr+            , alloc_frm_next = AllocFrame Map.empty Map.empty addr+            , alloc_frm_curr = alloc_frm_next ac+            , alloc_frm_prev = alloc_frm_curr ac+            }+    let m' = m { mem_alloc = ac' }+    return (m', alloc_frm_curr ac')++isNewRoot :: Allocation -> Bool+isNewRoot an = isPVarAddr (alloc_addr an) && not (BS.null (alloc_name an))++takeWrites :: TVar Writes -> STM Writes+takeWrites tv = do+    wb <- readTVar tv+    writeTVar tv (Writes Map.empty [])+    return wb++seralizeWrites :: WriteLog -> IO WriteBatch+seralizeWrites = Map.traverseWithKey (const writeTxW)++writeTxW :: TxW -> IO WriteCell+writeTxW (TxW pv v) =+    runVPutIO (pvar_space pv) (pvar_write pv v) >>= \ ((), _data, _deps) ->+    return (_data,_deps)++fnWriteAlloc :: Allocation -> WriteCell+fnWriteAlloc an = (alloc_data an, alloc_deps an)++syncSignal :: MVar () -> IO ()+syncSignal mv = void (tryPutMVar mv ())++-- Write the PVar roots and VRef hashmap. In these cases, the address+-- is the data, and a bytestring (a path or hash) is the key. I'm using+-- bytestring-sorted input, in this case, so we can easily insert these+-- in a sequential order (though they may be widely scattered).+--+-- In this case, I haven't encoded whether an entry in the UpdSeek map+-- is a deletion vs. an insertion. But, since I know where allocations+-- start, I can infer this information.+writeSecondaryIndexes :: VSpace -> MDB_txn -> Address -> UpdSeek -> IO ()+writeSecondaryIndexes vc txn allocInit updSeek =+    if (Map.null updSeek) then return () else+    alloca $ \ pAddr -> do+    let vAddr = MDB_val { mv_data = castPtr pAddr, mv_size = fromIntegral addrSize }+    croot <- mdb_cursor_open' txn (vcache_db_vroots vc) +    chash <- mdb_cursor_open' txn (vcache_db_caddrs vc)++    -- logic inlined for easy access to cursors and buffers+    let recordRoot vKey addr = do+            when (addr < allocInit) (fail "VCache bug: attempt to delete named root")+            let flags = compileWriteFlags [MDB_NOOVERWRITE]+            bOK <- mdb_cursor_put' flags croot vKey vAddr+            unless bOK (fail "VCache bug: attempt to overwrite named root")+    let insertHash vKey addr = do+            let flags = compileWriteFlags [MDB_NODUPDATA]+            bOK <- mdb_cursor_put' flags chash vKey vAddr+            unless bOK (addrBug addr "VRef hash recorded twice")+    let deleteHash vKey addr =+            alloca $ \ pvKey ->+            alloca $ \ pvAddr -> do+            poke pvKey vKey+            poke pvAddr vAddr+            bExist <- mdb_cursor_get' MDB_GET_BOTH chash pvKey pvAddr -- position cursor+            unless bExist (addrBug addr "VRef hash not found for deletion")+            let flags = compileWriteFlags []+            mdb_cursor_del' flags chash+    let processName (name, addrs) =+            withByteStringVal name $ \ vKey ->+            forM_ addrs $ \ addr ->+            poke pAddr addr >> -- prepares vAddr+            if isPVarAddr addr then recordRoot vKey addr else+            if addr < allocInit then deleteHash vKey addr else+            insertHash vKey addr++    -- process all (key, [address]) pairs+    mapM_ processName (Map.toAscList updSeek) ++    mdb_cursor_close' chash+    mdb_cursor_close' croot+    return ()+{-# NOINLINE writeSecondaryIndexes #-}++-- | Update reference counts in the database. This requires, for each+-- older address, reading the old reference count, updating it, then+-- writing the new value. Newer addresses may simply be appended. +--+-- VCache uses two tables for reference counts. One table just contains+-- zeroes. The other table includes positive counts. This separation +-- makes it easy for the garbage collector to find its targets. Zeroes+-- are also recorded to guarantee that GC can continue after a process+-- crashes.+--+-- Currently, I assume that all entries older than allocInit should+-- be recorded in the database, i.e. it's an error for both db_refct+-- and db_refct0 to be undefined unless I'm allocating a new address.+-- (Thus newPVar does need a placeholder.)+--+-- Ephemerons in the Haskell layer are not reference counted.+--+-- This operation should never fail. Failure indicates there is a bug+-- in VCache or some external source of database corruption. +--+updateReferenceCounts :: VSpace -> MDB_txn -> Address -> RefctDiff -> IO ()+updateReferenceCounts vc txn allocInit rcDiffMap =+    if Map.null rcDiffMap then return () else+    alloca $ \ pAddr ->+    allocaBytes 16 $ \ pRefctBuff -> -- overkill, but that's okay+    alloca $ \ pvAddr ->+    alloca $ \ pvData -> do+    let vAddr = MDB_val { mv_data = castPtr pAddr, mv_size = fromIntegral addrSize }+    let vZero = MDB_val { mv_data = nullPtr, mv_size = 0 }+    poke pvAddr vAddr -- the MDB_SET cursor operations will not update this+    wrc <- mdb_cursor_open' txn (vcache_db_refcts vc) -- write new reference counts+    wc0 <- mdb_cursor_open' txn (vcache_db_refct0 vc) -- write zeroes for ephemeral values++    -- the logic is inlined here for easy access to buffers and cursors+    let newEphemeron addr = do -- just write a zero+            let flags = compileWriteFlags [MDB_APPEND]+            bOK <- mdb_cursor_put' flags wc0 vAddr vZero+            unless bOK (addrBug addr "refct0 could not be appended")+    let newAllocation addr rc =+            if (0 == rc) then newEphemeron addr else do +            unless (rc > 0) (addrBug addr "allocation with negative refct")+            vRefct <- writeRefctBytes pRefctBuff rc+            let flags = compileWriteFlags [MDB_APPEND]+            bOK <- mdb_cursor_put' flags wrc vAddr vRefct+            unless bOK (addrBug addr "refct could not be appended")+    let updateFromZero addr rc = do+            bZeroFound <- mdb_cursor_get' MDB_SET wc0 pvAddr pvData+            unless bZeroFound (addrBug addr "has undefined refct")+            unless (rc > 0) (addrBug addr "update refct0 to negative refct")+            let df = compileWriteFlags []+            mdb_cursor_del' df wc0+            vRefct <- writeRefctBytes pRefctBuff rc+            let wf = compileWriteFlags [MDB_NOOVERWRITE]+            bOK <- mdb_cursor_put' wf wrc vAddr vRefct+            unless bOK (addrBug addr "could not update refct from zero")+    let deleteZero addr = do+            bFoundZero <- mdb_cursor_get' MDB_SET wc0 pvAddr pvData+            unless bFoundZero (addrBug addr "refct0 not found for deletion")+            let df = compileWriteFlags []+            mdb_cursor_del' df wc0+    let updateRefct (addr,rcDiff) = +            poke pAddr addr >> -- prepares vAddr, pvAddr+            if (addr >= allocInit) then newAllocation addr rcDiff else+            if (minBound == rcDiff) then deleteZero addr else -- sentinel for GC+            if (0 == rcDiff) then return () else -- zero delta, may skip+            mdb_cursor_get' MDB_SET wrc pvAddr pvData >>= \ bHasRefct ->+            if (not bHasRefct) then updateFromZero addr rcDiff else+            peek pvData >>= readRefctBytes >>= \ rcOld ->+            assert (rcOld > 0) $ +            let rc = rcOld + rcDiff in+            if (rc < 0) then addrBug addr "positive to negative refct" else+            if (0 == rc) +                then do let df = compileWriteFlags []+                        mdb_cursor_del' df wrc+                        let wf0 = compileWriteFlags [MDB_NOOVERWRITE]+                        bOK <- mdb_cursor_put' wf0 wc0 vAddr vZero+                        unless bOK (addrBug addr "has both refct0 and refct")+                else do vRefct <- writeRefctBytes pRefctBuff rc+                        let ucf = compileWriteFlags [MDB_CURRENT]+                        bOK <- mdb_cursor_put' ucf wrc vAddr vRefct+                        unless bOK (addrBug addr "could not update refct")++    -- process every reference count update+    mapM_ updateRefct (Map.toAscList rcDiffMap)+    mdb_cursor_close' wc0+    mdb_cursor_close' wrc+    return ()+{-# NOINLINE updateReferenceCounts #-}++-- paranoid checks for bugs that should be impossible+addrBug :: Address -> String -> IO a+addrBug addr msg = fail $ "VCache bug: address " ++ show addr ++ " " ++ msg++-- Since we only make one pass through memory, we need to maintain notes+-- about the changes in content:+--+--  * changes in reference counts from content+--  * hash values for deleted VRefs+-- +data UpdateNotes = UpdateNotes !RefctDiff !UpdSeek++emptyNotes :: UpdateNotes+emptyNotes = UpdateNotes Map.empty Map.empty++-- Typical CRUD, performed in a sorted-order pass, aggregating notes+-- useful for further processing.+updateVirtualMemory :: VSpace -> MDB_txn -> Address -> WriteBatch -> IO UpdateNotes+updateVirtualMemory vc txn allocStart fb = +    if Map.null fb then return emptyNotes else  +    alloca $ \ pAddr ->+    alloca $ \ pvAddr ->+    alloca $ \ pvOldData -> do+    let vAddr = MDB_val { mv_data = castPtr pAddr, mv_size = fromIntegral addrSize }+    poke pvAddr vAddr -- used with MDB_SET so should not be modified+    cmem <- mdb_cursor_open' txn (vcache_db_memory vc) ++    -- logic inlined here for easy access to cursors and buffers+    let create udn addr bytes =   +            withByteStringVal bytes $ \ vData -> do+            let cf = compileWriteFlags [MDB_APPEND]+            bOK <- mdb_cursor_put' cf cmem vAddr vData+            unless bOK (addrBug addr "created out of order")+            return udn -- no notes for allocations+    let update (UpdateNotes rcs hs) addr bytes = +            withByteStringVal bytes $ \ vData -> do+            unless (isPVarAddr addr) (addrBug addr "VRef cannot be updated")+            bExists <- mdb_cursor_get' MDB_SET cmem pvAddr pvOldData+            unless bExists (addrBug addr "undefined on update")+            oldDeps <- readDataDeps vc addr =<< peek pvOldData+            let rcs' = addRefcts oldDeps rcs+            let uf = compileWriteFlags [MDB_CURRENT]+            bOK <- mdb_cursor_put' uf cmem vAddr vData+            unless bOK (addrBug addr "could not updated")+            return (UpdateNotes rcs' hs)+    let delete (UpdateNotes rcs hs) addr = do+            bExists <- mdb_cursor_get' MDB_SET cmem pvAddr pvOldData+            unless bExists (addrBug addr "undefined on delete")+            vOldData <- peek pvOldData+            hs' <- if not (isVRefAddr addr) then return hs else+                   hashVal vOldData >>= \ h ->+                   return (addHash h addr hs)+            oldDeps <- readDataDeps vc addr vOldData+            let rcs' = addRefcts oldDeps rcs+            let df = compileWriteFlags []+            mdb_cursor_del' df cmem+            return (UpdateNotes rcs' hs')+    let processCell rcs (addr, (bytes, deps')) =+            poke pAddr addr >> -- +            if (BS.null bytes) then assert (L.null deps') $ delete rcs addr else+            if (addr >= allocStart) then create rcs addr bytes else+            update rcs addr bytes++    (UpdateNotes rcOld delSeek) <- foldM processCell emptyNotes (Map.toAscList fb)+    mdb_cursor_close' cmem++    assertValidOldDeps allocStart rcOld -- sanity check+    let rcNew = Map.foldr' (addRefcts . fmap putChildAddr . snd) Map.empty fb+    let rcDiff = Map.unionWith (-) rcNew rcOld+    return (UpdateNotes rcDiff delSeek)+{-# NOINLINE updateVirtualMemory #-}++-- here we might have one bytestring to many addresses... but this is +-- extremely unlikely.+addHash :: ByteString -> Address -> UpdSeek -> UpdSeek+addHash h addr = Map.alter f h where+    f = Just . (addr:) . maybe [] id ++addRefcts :: [Address] -> RefctDiff -> RefctDiff+addRefcts = flip (L.foldl' altr) where+    altr rc addr = Map.alter (Just . maybe 1 (+ 1)) addr rc ++-- sanity check: we should never have dependencies from+-- old content into the newly allocated space.   +assertValidOldDeps :: Address -> RefctDiff -> IO ()+assertValidOldDeps allocStart rcDepsOld = +    case Map.maxViewWithKey rcDepsOld of+        Nothing -> return ()+        Just ((maxOldDep,_), _) -> +            unless (maxOldDep < allocStart) (fail "VCache bug: time traveling allocator")++-- Read just enough of an MDB_val to obtain the address list.+readDataDeps :: VSpace -> Address -> MDB_val -> IO [Address]+readDataDeps vc addr vData = _vget vgetInit state0 >>= toDeps where+    toDeps (VGetR () sf) = return (vget_children sf)+    toDeps (VGetE eMsg) = addrBug addr $ "contains malformed data: " ++ eMsg+    state0 = VGetS+        { vget_children = []+        , vget_target = mv_data vData+        , vget_limit = mv_data vData `plusPtr` fromIntegral (mv_size vData)+        , vget_space = vc+        }+++-- | Garbage collection in VCache involves selecting addresses with+-- zero references, filtering objects that are held by VRefs and +-- PVars in Haskell memory, then deleting the remainders. +--+-- GC is incremental. We limiting the amount of work performed in+-- each write step to avoid creating too much latency for writers.+-- To keep up with heavy sustained work loads, GC rate will adapt +-- based on the write rates via the gcLimit argument. +--+runGarbageCollector :: VSpace -> MDB_txn -> Int -> IO GCBatch+runGarbageCollector vc txn gcLimit = do+    gcb0 <- gcCandidates vc txn gcLimit+    gcb <- gcSelectFrame vc gcb0+    gcClearFrame vc txn gcb+    return gcb+{-# NOINLINE runGarbageCollector #-}+++gcCandidates :: VSpace -> MDB_txn -> Int -> IO GCBatch+gcCandidates vc txn gcLimit =+    alloca $ \ pvAddr -> do+    c0 <- mdb_cursor_open' txn (vcache_db_refct0 vc)++    let loop !n !b !gcb = -- select candidates+            if (not b) then restartGC vc >> return gcb else+            (peek pvAddr >>= peekAddr) >>= \ addr ->+            let gcb' = Map.insert addr gcCell gcb in+            if (0 == n) then continueGC vc addr >> return gcb' else+            mdb_cursor_get' MDB_NEXT c0 pvAddr nullPtr >>= \ b' ->+            loop (n-1) b' gcb'++    let initC0 = -- continue GC or start from beginning of map+            readIORef (vcache_gc_start vc) >>= \ mbContinue ->+            case mbContinue of+                Nothing -> mdb_cursor_get' MDB_FIRST c0 pvAddr nullPtr+                Just addr -> alloca $ \ pAddr -> do+                    let vAddr = MDB_val { mv_data = castPtr pAddr+                                        , mv_size = fromIntegral $ sizeOf addr }+                    poke pAddr (1 + addr)+                    poke pvAddr vAddr+                    mdb_cursor_get' MDB_SET_RANGE c0 pvAddr nullPtr++    b0 <- initC0+    gcb <- loop (gcLimit - 1) b0 Map.empty+    mdb_cursor_close' c0+    return gcb++-- filter candidates for ephemeral addresses then record the GC frame.+gcSelectFrame :: VSpace -> GCBatch -> IO GCBatch+gcSelectFrame vc gcb = +    modifyMVarMasked (vcache_memory vc) $ \ m -> do+    let gcb' = (((gcb `Map.difference` mem_evrefs m) +                      `Map.difference` mem_cvrefs m) +                      `Map.difference` mem_pvars  m) +    let gc' = GC { gc_frm_curr = GCFrame gcb'+                 , gc_frm_prev = gc_frm_curr (mem_gc m) }+    let m' = m { mem_gc = gc' }+    return (m', gcb')++-- delete GC'd addresses from the db_refct0 table. Returns +-- number of addresses in +gcClearFrame :: VSpace -> MDB_txn -> GCBatch -> IO ()+gcClearFrame vc txn gcb = +    alloca $ \ pAddr -> +    alloca $ \ pvAddr -> do+    let vAddr = MDB_val { mv_data = castPtr pAddr, mv_size = fromIntegral addrSize }+    poke pvAddr vAddr+    c0 <- mdb_cursor_open' txn (vcache_db_refct0 vc)+    +    let clearAddr addr = do+            poke pAddr addr+            bFound <- mdb_cursor_get' MDB_SET c0 pvAddr nullPtr+            unless bFound (addrBug addr "not found for GC")+            let flags = compileWriteFlags []+            mdb_cursor_del' flags c0++    mapM_ clearAddr (Map.keys gcb)+    mdb_cursor_close' c0+    return ()+   + +-- GC from first address (affects next frame)+restartGC :: VSpace -> IO ()+restartGC vc = writeIORef (vcache_gc_start vc) Nothing++-- GC from given address (affects next frame)+continueGC :: VSpace -> Address -> IO ()+continueGC vc !addr = writeIORef (vcache_gc_start vc) (Just addr)++gcCell :: WriteCell+gcCell = (BS.empty, [])    ++peekAddr :: MDB_val -> IO Address+peekAddr v =+    let expectedSize = fromIntegral addrSize in+    let bBadSize = expectedSize /= mv_size v in+    if bBadSize then fail "VCache bug: badly formed address" else+    peekAligned (castPtr (mv_data v))+{-# INLINABLE peekAddr #-}+

@@ -0,0 +1,77 @@+Name: vcache+Version: 0.1+Synopsis: large, persistent, memcached values and structure sharing for Haskell +Category: Database+Description:+  VCache provides a nearly-transparent persistent memory for Haskell+  with transactional variables, persistent roots, and large structured+  values. The virtual space is a memory-mapped file via LMDB, with +  structure sharing and incremental GC. +  .+  VCache is very similar to packages acid-state, perdure, and TCache.+  VCache is intended as an acid-state alternative, offering flexibility+  to model fine-grained variables or extremely large values.+  +Author: David Barbour+Maintainer: dmbarbour@gmail.com+Homepage: http://github.com/dmbarbour/haskell-vcache++Package-Url: +Copyright: (c) 2014 by David Barbour+License: BSD3+license-file: LICENSE+Stability: experimental+build-type: Simple+cabal-version: >= 1.16.0.3++Source-repository head+  type: git+  location: http://github.com/dmbarbour/haskell-vcache.git++Library+  hs-Source-Dirs: hsrc_lib+  default-language: Haskell2010+  Build-Depends: base (>= 4.6 && < 5)+    , direct-murmur-hash+    , bytestring+    , transformers+    , containers (>= 0.5)+    , stm (>= 2.4.3)+    , lmdb (>= 0.2.5)+    , filelock+    , easy-file+    , random (>= 1.0)++  Exposed-Modules:+    Database.VCache+    Database.VCache.VRef+    Database.VCache.PVar+    Database.VCache.VTx+    Database.VCache.VCacheable+    Database.VCache.VPut+    Database.VCache.VGet++    Database.VCache.Path+    Database.VCache.Sync+    Database.VCache.Stats+    Database.VCache.Cache++  Other-Modules:+    Database.VCache.Types+    Database.VCache.Open+    Database.VCache.Aligned+    Database.VCache.RWLock+    Database.VCache.Hash+    Database.VCache.VGetAux+    Database.VCache.VGetInit+    Database.VCache.VPutAux+    Database.VCache.VPutFini+    -- Database.VCache.Adjacency+    Database.VCache.Alloc+    Database.VCache.Read+    Database.VCache.Write+    Database.VCache.Clean+    Database.VCache.Refct+   +  ghc-options: -Wall -auto-all+