From 4ab17008c488bc1ff7342d0c845e13e853db5301 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 19 Aug 2025 20:21:57 +0300 Subject: [PATCH] endurance test + multiple fixes --- .../lib/HBS2/Storage/NCQ3/Internal.hs | 3 +- .../lib/HBS2/Storage/NCQ3/Internal/Files.hs | 51 +++++++++++-------- .../lib/HBS2/Storage/NCQ3/Internal/Fossil.hs | 21 ++++++-- .../lib/HBS2/Storage/NCQ3/Internal/Index.hs | 10 ++-- .../lib/HBS2/Storage/NCQ3/Internal/Run.hs | 6 ++- .../lib/HBS2/Storage/NCQ3/Internal/Sweep.hs | 7 +-- .../lib/HBS2/Storage/NCQ3/Internal/Types.hs | 1 + hbs2-tests/scripts/ncq3/t1.ss | 19 +++++++ 8 files changed, 84 insertions(+), 34 deletions(-) create mode 100644 hbs2-tests/scripts/ncq3/t1.ss diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs index bfb5a2ba..47bff7ab 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs @@ -67,6 +67,7 @@ ncqStorageOpen fp upd = do ncqStateUse <- newTVarIO mempty ncqServiceSem <- atomically $ newTSem 1 ncqFileLock <- newTVarIO Nothing + ncqCurrentFossils <- newTVarIO mempty let ncq = NCQStorage{..} & upd @@ -231,7 +232,7 @@ ncqTryLoadState me@NCQStorage{..} = do if not corrupted then do debug $ yellow "indexing" <+> pretty dataFile - ncqIndexFile me dataFile + ncqIndexFile me Nothing dataFile else do o <- ncqFileTryRecover path diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Files.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Files.hs index f82c5191..6b0eaa7a 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Files.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Files.hs @@ -7,6 +7,8 @@ import HBS2.Storage.NCQ3.Internal.Types import System.Posix.Files qualified as PFS import Data.List qualified as List +{- HLINT ignore "Eta reduce" -} + removeFile :: MonadIO m => FilePath -> m () removeFile fp = do @@ -49,29 +51,36 @@ ncqListFilesBy me@NCQStorage{..} filt = do pure $ List.sortOn ( Down . fst ) r +ncqFindMinPairOfBy :: forall fa m . (ToFileName fa, MonadUnliftIO m) + => NCQStorage + -> (fa -> Bool) -- ^ eligible predicate + -> [fa] + -> m (Maybe (NCQFileSize, fa, fa)) +ncqFindMinPairOfBy sto eligible lst = + go lst Nothing + where + go :: [fa] -> Maybe (NCQFileSize, fa, fa) -> m (Maybe (NCQFileSize, fa, fa)) + go (a:b:rest) best = do + best' <- if eligible a && eligible b + then do + let pa = ncqGetFileName sto a + let pb = ncqGetFileName sto b + s1 <- fsize pa + s2 <- fsize pb + let sz = fromIntegral (s1 + s2) + pure $ case best of + Nothing -> Just (sz, a, b) + Just (sz0,_,_) | sz Just (sz, a, b) + _ -> best + else pure best + go (b:rest) best' + go _ best = pure best + + fsize s = liftIO (PFS.getFileStatus s) <&> PFS.fileSize + ncqFindMinPairOf :: forall fa m . (ToFileName fa, MonadUnliftIO m) => NCQStorage -> [fa] -> m (Maybe (NCQFileSize, fa, fa)) -ncqFindMinPairOf sto lst = do - - let files = fmap (\x -> (x, ncqGetFileName sto x)) lst - - flip fix (files, Nothing) $ \next (fs, r) -> do - case fs of - [] -> pure r - [ _ ] -> pure r - ( s1 : s2 : ss ) -> do - size1 <- fsize (snd s1) - size2 <- fsize (snd s2) - let size = fromIntegral $ size1 + size2 - - case r of - Nothing -> next (s2 : ss, Just (size, fst s1, fst s2) ) - e@(Just (size0, _, _)) | size0 > size -> next (s2 : ss, Just (size, fst s1, fst s2) ) - | otherwise -> next (s2:ss, e) - - where fsize s = liftIO (PFS.getFileStatus s) <&> PFS.fileSize - - +ncqFindMinPairOf sto lst = ncqFindMinPairOfBy sto (const True) lst diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs index f81612f9..87943fc8 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs @@ -1,3 +1,4 @@ +{-# Language RecordWildCards #-} module HBS2.Storage.NCQ3.Internal.Fossil where import HBS2.Storage.NCQ3.Internal.Prelude @@ -7,6 +8,7 @@ import HBS2.Storage.NCQ3.Internal.Index import HBS2.Storage.NCQ3.Internal.State import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM import Data.List qualified as List import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS @@ -61,6 +63,7 @@ ncqFossilMergeStep :: forall m . MonadUnliftIO m -> m Bool ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do + tmax <- liftIO getPOSIXTime >>= newTVarIO debug "ncqFossilMergeStep" @@ -69,7 +72,12 @@ ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu <&> fmap DataFile . HS.toList . ncqStateFiles <&> List.sortOn Down - r' <- lift $ ncqFindMinPairOf me files + NCQState{..} <- readTVarIO ncqState + + let tss = ncqStateIndex & fmap (\(Down x, y) -> (y, realToFrac x :: POSIXTime)) & HM.fromList + + cur <- readTVarIO ncqCurrentFossils + r' <- lift $ ncqFindMinPairOfBy me (\x -> not (HS.member (coerce x) cur)) files r@(sumSize, f1, f2) <- ContT $ maybe1 r' (pure False) @@ -84,6 +92,7 @@ ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu ContT $ bracket none $ const do removeFile outFile + liftIO $ withBinaryFileAtomic outFile WriteMode $ \fwh -> do fd <- handleToFd fwh @@ -96,8 +105,7 @@ ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu Nothing -> pure False Just (InMemory{}) -> pure False Just (InFossil fk oi si) -> do - let skip = fk > fik || (fk == fik && o < fromIntegral oi) - let beWritten = not skip + let beWritten = fk == fik && o == fromIntegral oi -- let c = if skip then green else id -- when (si == ncqTombEntrySize) do @@ -107,9 +115,11 @@ ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu -- <+> "write" <+> c (pretty beWritten) atomically do + tj <- readTVar tmax + modifyTVar tmax (max (fromMaybe tj (HM.lookup fk tss))) here <- readTVar already <&> HS.member k let proceed = not here && beWritten - modifyTVar already (HS.insert k) + when proceed $ modifyTVar already (HS.insert k) pure proceed appendTailSection fd @@ -126,7 +136,8 @@ ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu ncqStateUpdate me do ncqStateAddFact (P (PData f3 ss)) - lift $ ncqIndexFile me f3 + ts <- readTVarIO tmax + lift $ ncqIndexFile me (Just ts) f3 ncqStateUpdate me do ncqStateDelDataFile (coerce f1) diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs index 043c620e..9013e338 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs @@ -84,8 +84,12 @@ ncqLocate :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Location) ncqLocate me href = ncqOperation me (pure Nothing) do ncqLocate_ True me href -ncqIndexFile :: MonadUnliftIO m => NCQStorage -> DataFile FileKey -> m (Maybe FilePath) -ncqIndexFile n fk = runMaybeT do +ncqIndexFile :: MonadUnliftIO m + => NCQStorage + -> Maybe POSIXTime + -> DataFile FileKey + -> m (Maybe FilePath) +ncqIndexFile n ts' fk = runMaybeT do let fp = toFileName fk & ncqGetFileName n fki <- ncqGetNewFileKey n IndexFile @@ -110,7 +114,7 @@ ncqIndexFile n fk = runMaybeT do moveFile result dest stat <- liftIO $ PFS.getFileStatus dest - let ts = PFS.modificationTimeHiRes stat + let ts = fromMaybe (PFS.modificationTimeHiRes stat) ts' midx <- liftIO (nwayHashMMapReadOnly dest) diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs index 19aee37e..13d1b1a3 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs @@ -49,7 +49,9 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do if not stop then STM.retry else pure Nothing maybe1 what none $ \(fk :: FileKey) -> do - ncqIndexFile ncq (DataFile fk) >> loop + ncqIndexFile ncq Nothing (DataFile fk) + atomically $ modifyTVar ncqCurrentFossils (HS.delete fk) + loop let shLast = V.length ncqWriteOps - 1 spawnActivity $ pooledForConcurrentlyN_ (V.length ncqWriteOps) [0..shLast] $ \i -> do @@ -212,6 +214,8 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do openNewDataFile = do fk <- ncqGetNewFileKey ncq DataFile + atomically $ modifyTVar ncqCurrentFossils (HS.insert fk) + ncqStateUpdate ncq (ncqStateAddDataFile fk) let fname = ncqGetFileName ncq (DataFile fk) diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Sweep.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Sweep.hs index d22b5cf0..8c71c031 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Sweep.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Sweep.hs @@ -15,10 +15,11 @@ import Data.HashMap.Strict qualified as HM ncqLiveKeysSTM :: NCQStorage -> STM (HashSet FileKey) ncqLiveKeysSTM NCQStorage{..} = do - s0 <- readTVar ncqState - merged <- readTVar ncqStateUse <&> (s0<>) . foldMap fst . HM.elems + s0 <- readTVar ncqState + merged <- readTVar ncqStateUse <&> (s0<>) . foldMap fst . HM.elems + current <- readTVar ncqCurrentFossils - pure $ HS.fromList $ universeBi @_ @FileKey merged + pure $ current <> HS.fromList (universeBi @_ @FileKey merged) ncqLiveKeys :: forall m . MonadIO m => NCQStorage -> m (HashSet FileKey) ncqLiveKeys ncq = atomically $ ncqLiveKeysSTM ncq diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs index 587ff72f..bbdba54a 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs @@ -93,6 +93,7 @@ data NCQStorage = , ncqState :: TVar NCQState , ncqStateKey :: TVar FileKey , ncqStateUse :: TVar (HashMap FileKey (NCQState, TVar Int)) + , ncqCurrentFossils :: TVar (HashSet FileKey) , ncqWrites :: TVar Int , ncqWriteEMA :: TVar Double -- for writes-per-seconds , ncqWriteQ :: TVar (Seq HashRef) diff --git a/hbs2-tests/scripts/ncq3/t1.ss b/hbs2-tests/scripts/ncq3/t1.ss new file mode 100644 index 00000000..a648d535 --- /dev/null +++ b/hbs2-tests/scripts/ncq3/t1.ss @@ -0,0 +1,19 @@ +test:root temp +test:dir:keep +set! w:getblk 100 +set! w:storm 2 +set! w:putblk 90 +set! w:blk 65536 + +println "w:blk" w:blk +println "go" + +; test:ncq3:endurance:inproc 200000 +test:ncq3:endurance:inproc 300000 + + + + + + +