diff --git a/cbits/posix.c b/cbits/posix.c new file mode 100644 --- /dev/null +++ b/cbits/posix.c @@ -0,0 +1,21 @@ +#include "HsMsync.h" + +#define _LARGEFILE64_SOURCE 1 +#define _FILE_OFFSET_BITS 64 + +#include + +int system_io_msync(void *ptr, size_t size, int hs_flags) +{ + int flags = 0; + if (hs_flags & 1) { + flags |= MS_SYNC; + } + if (hs_flags & 2) { + flags |= MS_ASYNC; + } + if (hs_flags & 4) { + flags |= MS_INVALIDATE; + } + return msync(ptr, size, flags); +} diff --git a/cbits/win32.c b/cbits/win32.c new file mode 100644 --- /dev/null +++ b/cbits/win32.c @@ -0,0 +1,7 @@ +#include "HsMsync.h" + +#include + +int system_io_msync(void *ptr, size_t size, int hs_flags) +{ +} diff --git a/keyvaluehash.cabal b/keyvaluehash.cabal --- a/keyvaluehash.cabal +++ b/keyvaluehash.cabal @@ -1,12 +1,22 @@ name: keyvaluehash -version: 0.3.0.2 +version: 0.3.1 synopsis: Pure Haskell key/value store implementation --- description: +description: A simple bytestring key/value store implemented + in terms of hash table over a file. + + It cannot yet grow/shrink the hash table as + needed, nor does it free old unused (key,value) + pair storage. + + Mostly useful for applications that need not + worry about the size of their persistent store. + + Reduces dependency hell. license: BSD3 license-file: LICENSE author: Eyal Lotem maintainer: eyal.lotem@gmail.com --- copyright: +copyright: Eyal Lotem category: Database build-type: Simple cabal-version: >=1.8 @@ -14,8 +24,17 @@ library hs-Source-Dirs: src exposed-modules: Database.KeyValueHash - other-modules: Database.GrowingFile, Database.FileArray + other-modules: Database.GrowingFile, Database.FileArray, System.IO.MMap.Sync build-depends: base >= 3 && <10, filepath, directory, bytestring, hashable, binary, derive, mmap, array, storable-record + Include-dirs: cbits ghc-options: -O2 -Wall ghc-prof-options: -Wall -auto-all -caf-all -rtsopts + if os(mingw32) + C-sources: cbits/win32.c + else + C-sources: cbits/posix.c + +source-repository head + type: git + location: https://github.com/Peaker/keyvaluehash.git diff --git a/src/Database/FileArray.hs b/src/Database/FileArray.hs --- a/src/Database/FileArray.hs +++ b/src/Database/FileArray.hs @@ -4,6 +4,7 @@ , create, open, close , Element(..) , unsafeElement -- no index checks + , msync ) where import Control.Monad (when) @@ -17,9 +18,10 @@ import qualified Foreign.Storable as Storable import qualified System.IO as IO import qualified System.IO.MMap as MMap +import qualified System.IO.MMap.Sync as MMapSync data FileArray a = FileArray - { _faCount :: Word64 + { faCount :: Word64 , faPtr :: ForeignPtr a } @@ -69,3 +71,12 @@ withForeignPtr (faPtr fileArray) $ \keysPtr -> do let ptr = keysPtr `plusPtr` fromIntegral (ix * elementSize fileArray) return $ Element (Storable.peek ptr) (Storable.poke ptr) + +msync :: Storable a => FileArray a -> IO () +msync fileArray = + withForeignPtr (faPtr fileArray) $ + \ptr -> + MMapSync.msync ptr (fromIntegral fileSize) + (Just MMapSync.Async) MMapSync.NoInvalidate + where + fileSize = faCount fileArray * elementSize fileArray diff --git a/src/Database/GrowingFile.hs b/src/Database/GrowingFile.hs --- a/src/Database/GrowingFile.hs +++ b/src/Database/GrowingFile.hs @@ -4,6 +4,7 @@ , create, open, close , readRange, writeRange , append + , msync ) where import Control.Applicative (liftA2) @@ -22,6 +23,7 @@ import qualified Foreign.Storable as Storable import qualified System.IO as IO import qualified System.IO.MMap as MMap +import qualified System.IO.MMap.Sync as MMapSync data Header = Header { hAllocated :: Word64 @@ -152,3 +154,10 @@ resize gfile header newUsed writeRange gfile curUsed bs return curUsed + +msync :: GrowingFile -> IO () +msync gfile = do + header <- readHeader gfile + fptr <- readIORef (gfPtr gfile) + withForeignPtr fptr $ \ptr -> + MMapSync.msync ptr (fromIntegral (hUsed header)) (Just MMapSync.Async) MMapSync.NoInvalidate diff --git a/src/Database/KeyValueHash.hs b/src/Database/KeyValueHash.hs --- a/src/Database/KeyValueHash.hs +++ b/src/Database/KeyValueHash.hs @@ -6,6 +6,7 @@ , Database, createDatabase, openDatabase, closeDatabase , withCreateDatabase, withOpenDatabase , readKey, writeKey, deleteKey + , msync ) where import Control.Applicative ((<$>), (<*>)) @@ -15,7 +16,7 @@ import Data.Binary.Put (runPut) import Data.Derive.Binary(makeBinary) import Data.DeriveTH(derive) -import Data.Hashable (Hashable, hash) +import Data.Hashable (hashWithSalt) import Data.List (intercalate) import Data.Monoid (mconcat) import Data.Typeable (Typeable) @@ -66,7 +67,7 @@ } stdHash :: HashFunction -stdHash = mkHashFunc "Hashable" (fromIntegral . hash) +stdHash = mkHashFunc "Hashable" (fromIntegral . hashWithSalt 0xDEADBEEF) type ValuePtr = Word64 -- offset in values file type KeyPtr = Word64 -- index in key file @@ -280,3 +281,8 @@ Nothing -> -- TODO: Throw exception? return () + +msync :: Database -> IO () +msync db = do + FileArray.msync $ dbKeysArray db + GrowingFile.msync $ dbValues db diff --git a/src/System/IO/MMap/Sync.hs b/src/System/IO/MMap/Sync.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/MMap/Sync.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module System.IO.MMap.Sync (msync, SyncFlag(..), InvalidateFlag(..)) where + +import Control.Monad (when) +import Data.Int (Int64) +import Foreign.C.Error (throwErrno) +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.Ptr (Ptr) + +-- TODO: This should be in the mmap package + +data SyncFlag = Async | Sync + deriving (Eq, Ord, Read, Show) +data InvalidateFlag = Invalidate | NoInvalidate + deriving (Eq, Ord, Read, Show) + +foreign import ccall unsafe "HsMsync.h system_io_msync" + c_system_io_msync :: Ptr a -> CSize -> CInt -> IO CInt + +mkMSyncFlag :: Maybe SyncFlag -> CInt +mkMSyncFlag Nothing = 0 +mkMSyncFlag (Just Sync) = 1 +mkMSyncFlag (Just Async) = 2 + +mkInvalidateFlag :: InvalidateFlag -> CInt +mkInvalidateFlag NoInvalidate = 0 +mkInvalidateFlag Invalidate = 4 + +mkFlags :: Maybe SyncFlag -> InvalidateFlag -> CInt +mkFlags mSyncFlag invalidateFlag = + mkMSyncFlag mSyncFlag + + mkInvalidateFlag invalidateFlag + +msync :: Ptr a -> Int64 -> Maybe SyncFlag -> InvalidateFlag -> IO () +msync ptr size mSyncFlag invalidateFlag = do + res <- + c_system_io_msync ptr (fromIntegral size) $ + mkFlags mSyncFlag invalidateFlag + when (res == -1) $ throwErrno "msync failed"