diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 418731c5..657279c7 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -74,6 +74,7 @@ library , filepath , microlens-platform , mtl + , mmap , prettyprinter , random , safe diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs index 0100e362..76ac78d2 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs @@ -37,6 +37,9 @@ import Control.Concurrent.STM.TSem import Safe import UnliftIO +import Foreign.Ptr +import System.IO.MMap + -- import System.Posix.IO -- import System.Posix.Fcntl import System.Posix.Types @@ -116,14 +119,18 @@ isFresh e = case e of type Bucket = TVar (HashMap ByteString Entry) +type MMaped = (Ptr (), Int, Int, Int) + data CompactStorage k = CompactStorage { csBuckets :: Int + , csFile :: FilePath , csHandle :: MVar Handle , csHeaderOff :: TVar EntryOffset , csSeq :: TVar Integer , csKeys :: Vector Bucket , csUncommitted :: TVar Integer + , csMMapped :: TVar MMaped } type ForCompactStorage m = MonadIO m @@ -145,19 +152,6 @@ getBucket sto bs = do {-# INLINE getBucket #-} --- openFileForReadWrite :: FilePath -> IO (Fd, Fd) --- openFileForReadWrite fp = do --- fdW <- openFd fp ReadWrite (Just ownerModes) defaultFileFlags { nonBlock = True } --- fdR <- openFd fp ReadOnly Nothing defaultFileFlags { nonBlock = True } --- return (fdW, fdR) - --- -- Преобразование Fd в Handle --- fdToHandleReadWrite :: (Fd, Fd) -> IO (Handle, Handle) --- fdToHandleReadWrite (fdW, fdR) = do --- haW <- fdToHandle fdW --- haR <- fdToHandle fdR --- return (haW, haR) - compactStorageOpen :: ForCompactStorage m => [CompactStorageOpenOpt] -> FilePath @@ -179,12 +173,15 @@ compactStorageOpen _ fp = do ss <- newTVarIO 0 + mmapped <- liftIO (mmapFilePtr fp ReadOnly (Just (0, fromIntegral sz))) + >>= newTVarIO + if sz == 0 then - pure $ CompactStorage buck mha hoff0 ss keys0 uncommitted + pure $ CompactStorage buck fp mha hoff0 ss keys0 uncommitted mmapped else do (p,header) <- readHeader mha Nothing >>= maybe (throwIO InvalidHeader) pure hoff <- newTVarIO p - let sto = CompactStorage buck mha hoff ss keys0 uncommitted + let sto = CompactStorage buck fp mha hoff ss keys0 uncommitted mmapped readIndex sto (hdrIndexOffset header) (hdrIndexEntries header) flip fix (hdrPrev header) $ \next -> \case @@ -302,6 +299,10 @@ compactStorageCommit sto = liftIO do offLast <- hTell ha <&> fromIntegral + sz <- hFileSize ha + + remapFile sz + atomically do writeTVar (csHeaderOff sto) (offLast - headerSize 1) for_ idxEntries $ \(e,i) -> do @@ -324,6 +325,13 @@ compactStorageCommit sto = liftIO do getSeq = \case Entry i _ -> i + remapFile :: ForCompactStorage m => Integer -> m () + remapFile sz = do + let fp = csFile sto + unmapFile sto + mmapped <- liftIO (mmapFilePtr fp ReadOnly (Just (0, fromIntegral sz))) + atomically (writeTVar (csMMapped sto) mmapped) + compactStorageDel :: ForCompactStorage m => CompactStorage k -> ByteString -> m () compactStorageDel sto key = do @@ -404,11 +412,22 @@ compactStorageExists sto key = do Just (Entry _ (Off e)) -> pure (Just (fromIntegral $ idxEntrySize e)) _ -> pure Nothing +unmapFile :: ForCompactStorage m => CompactStorage sto -> m () +unmapFile sto = do + mmapped <- readTVarIO (csMMapped sto) + liftIO $ munmapFilePtr (view _1 mmapped) (view _2 mmapped) + -- NOTE: mmapped-is-invalid-now + -- если теперь позвать что-то, что + -- читает из этого мапинга -- то всё грохнется + + compactStorageClose :: ForCompactStorage m => CompactStorage k -> m () compactStorageClose sto = do compactStorageCommit sto -- FIXME: hangs-forever-on-io-exception - liftIO $ withMVar (csHandle sto) hClose + liftIO $ do + unmapFile sto + withMVar (csHandle sto) hClose compactStorageFindLiveHeads :: ForCompactStorage m => FilePath