diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/hsrc_lib/Database/VCache.hs b/hsrc_lib/Database/VCache.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache.hs @@ -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 diff --git a/hsrc_lib/Database/VCache/Aligned.hs b/hsrc_lib/Database/VCache/Aligned.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Aligned.hs @@ -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' #-} diff --git a/hsrc_lib/Database/VCache/Alloc.hs b/hsrc_lib/Database/VCache/Alloc.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Alloc.hs @@ -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 + diff --git a/hsrc_lib/Database/VCache/Cache.hs b/hsrc_lib/Database/VCache/Cache.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Cache.hs @@ -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 #-} + + diff --git a/hsrc_lib/Database/VCache/Clean.hs b/hsrc_lib/Database/VCache/Clean.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Clean.hs @@ -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) () diff --git a/hsrc_lib/Database/VCache/Hash.hs b/hsrc_lib/Database/VCache/Hash.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Hash.hs @@ -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 diff --git a/hsrc_lib/Database/VCache/Open.hs b/hsrc_lib/Database/VCache/Open.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Open.hs @@ -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' [] = [] + diff --git a/hsrc_lib/Database/VCache/PVar.hs b/hsrc_lib/Database/VCache/PVar.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/PVar.hs @@ -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) + diff --git a/hsrc_lib/Database/VCache/Path.hs b/hsrc_lib/Database/VCache/Path.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Path.hs @@ -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 #-} diff --git a/hsrc_lib/Database/VCache/RWLock.hs b/hsrc_lib/Database/VCache/RWLock.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/RWLock.hs @@ -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', []) diff --git a/hsrc_lib/Database/VCache/Read.hs b/hsrc_lib/Database/VCache/Read.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Read.hs @@ -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 + + diff --git a/hsrc_lib/Database/VCache/Refct.hs b/hsrc_lib/Database/VCache/Refct.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Refct.hs @@ -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 } + diff --git a/hsrc_lib/Database/VCache/Stats.hs b/hsrc_lib/Database/VCache/Stats.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Stats.hs @@ -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 + } + diff --git a/hsrc_lib/Database/VCache/Sync.hs b/hsrc_lib/Database/VCache/Sync.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Sync.hs @@ -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 diff --git a/hsrc_lib/Database/VCache/Types.hs b/hsrc_lib/Database/VCache/Types.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Types.hs @@ -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 + diff --git a/hsrc_lib/Database/VCache/VCacheable.hs b/hsrc_lib/Database/VCache/VCacheable.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VCacheable.hs @@ -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 #-} + + diff --git a/hsrc_lib/Database/VCache/VGet.hs b/hsrc_lib/Database/VCache/VGet.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VGet.hs @@ -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 + diff --git a/hsrc_lib/Database/VCache/VGetAux.hs b/hsrc_lib/Database/VCache/VGetAux.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VGetAux.hs @@ -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 #-} + diff --git a/hsrc_lib/Database/VCache/VGetInit.hs b/hsrc_lib/Database/VCache/VGetInit.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VGetInit.hs @@ -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 + diff --git a/hsrc_lib/Database/VCache/VPut.hs b/hsrc_lib/Database/VCache/VPut.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VPut.hs @@ -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) + + diff --git a/hsrc_lib/Database/VCache/VPutAux.hs b/hsrc_lib/Database/VCache/VPutAux.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VPutAux.hs @@ -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 diff --git a/hsrc_lib/Database/VCache/VPutFini.hs b/hsrc_lib/Database/VCache/VPutFini.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VPutFini.hs @@ -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) + diff --git a/hsrc_lib/Database/VCache/VRef.hs b/hsrc_lib/Database/VCache/VRef.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VRef.hs @@ -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 #-} + + + diff --git a/hsrc_lib/Database/VCache/VTx.hs b/hsrc_lib/Database/VCache/VTx.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/VTx.hs @@ -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 #-} + diff --git a/hsrc_lib/Database/VCache/Write.hs b/hsrc_lib/Database/VCache/Write.hs new file mode 100644 --- /dev/null +++ b/hsrc_lib/Database/VCache/Write.hs @@ -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 #-} + diff --git a/vcache.cabal b/vcache.cabal new file mode 100644 --- /dev/null +++ b/vcache.cabal @@ -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 +