wip, 3x speed degradation on read+write scenario against NCQ1

This commit is contained in:
voidlizard 2025-08-14 09:53:00 +03:00
parent 802f6d65f3
commit 59e9f8a718
3 changed files with 47 additions and 7 deletions

View File

@ -30,7 +30,7 @@ ncqStorageOpen fp upd = do
let ncqGen = 0 let ncqGen = 0
let ncqFsync = 16 * megabytes let ncqFsync = 16 * megabytes
let ncqWriteQLen = 1024 * 4 let ncqWriteQLen = 1024 * 4
let ncqMinLog = 1 * gigabytes let ncqMinLog = 2 * gigabytes
let ncqMaxLog = 32 * gigabytes let ncqMaxLog = 32 * gigabytes
let ncqWriteBlock = max 128 $ ncqWriteQLen `div` 2 let ncqWriteBlock = max 128 $ ncqWriteQLen `div` 2
let ncqMaxCachedIndex = 64 let ncqMaxCachedIndex = 64
@ -109,7 +109,7 @@ ncqPutBlock0 :: MonadUnliftIO m
-> LBS.ByteString -> LBS.ByteString
-> Bool -> Bool
-> m (Maybe HashRef) -> m (Maybe HashRef)
ncqPutBlock0 sto lbs wait = ncqPutBlock0 sto lbs wait = do
ncqLocate sto ohash >>= \case ncqLocate sto ohash >>= \case
Nothing -> Just <$> work sto (Just B) (Just ohash) bs Nothing -> Just <$> work sto (Just B) (Just ohash) bs
_ -> pure (Just ohash) _ -> pure (Just ohash)

View File

@ -78,6 +78,7 @@ ncqLocate_ f me@NCQStorage{..} href = ncqOperation me (pure Nothing) do
writeTQueue ncqReadReq (href, answ) writeTQueue ncqReadReq (href, answ)
atomically $ takeTMVar answ atomically $ takeTMVar answ
{-# INLINE ncqLocate_ #-}
ncqLocate :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Location) ncqLocate :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Location)
ncqLocate me href = ncqOperation me (pure Nothing) do ncqLocate me href = ncqOperation me (pure Nothing) do

View File

@ -590,6 +590,32 @@ ncq3Tests = do
notice $ "second must fail" <+> pretty wx <+> "=>" <+> viaShow r notice $ "second must fail" <+> pretty wx <+> "=>" <+> viaShow r
entry $ bindMatch "test:ncq3:merkle:file" $ nil_ $ \e -> runTest $ \TestEnv{..} -> do
let (opts,args) = splitOpts [] e
let n = headDef (1 * gigabytes) [ fromIntegral x | LitIntVal x <- args ]
fn <- orThrowUser "no file given" (headMay [ x | StringLike x <- args ])
ncqWithStorage testEnvDir $ \ncq -> do
let sto = AnyStorage ncq
-- lbs <- liftIO $ LBS.readFile fn
lbs <- liftIO $ LBS.readFile fn
chu <- S.toList_ (readChunkedBS lbs (256*1024))
hashes <- forConcurrently chu $ \chunk -> do
ncqTossBlock ncq chunk >>= orThrowUser "can't save"
-- FIXME: handle-hardcode
let pt = toPTree (MaxSize 1024) (MaxNum 256) hashes -- FIXME: settings
m <- makeMerkle 0 pt $ \(_,_,bss) -> liftIO do
void $ ncqPutBlock ncq bss >>= orThrowUser "can't save"
notice $ pretty m
entry $ bindMatch "test:ncq3:merkle" $ nil_ $ \e -> runTest $ \TestEnv{..} -> do entry $ bindMatch "test:ncq3:merkle" $ nil_ $ \e -> runTest $ \TestEnv{..} -> do
let (opts,args) = splitOpts [] e let (opts,args) = splitOpts [] e
@ -630,13 +656,26 @@ ncq3Tests = do
h0 <- liftIO (LBS.readFile fn) <&> HashRef . hashObject @HbSync h0 <- liftIO (LBS.readFile fn) <&> HashRef . hashObject @HbSync
lbs1 <- runExceptT (getTreeContents sto tree) debug $ pretty h0
>>= orThrowPassIO
<&> HashRef . hashObject @HbSync
notice $ "found" <+> pretty tree <+> pretty lbs1 <+> pretty h0 notice "full compact index first"
liftIO $ assertBool (show $ "hash eq" <+> pretty h0 <+> pretty lbs1) (h0 == lbs1) -- ncqIndexCompactFull ncq
replicateM_ 3 do
t1 <- getTimeCoarse
lbs1 <- runExceptT (getTreeContents sto tree)
>>= orThrowPassIO
<&> HashRef . hashObject @HbSync
debug $ pretty lbs1
t3 <- getTimeCoarse
notice $ "found" <+> pretty (sec2 (1e-9 * realToFrac (t3 - t1))) <+> pretty lbs1 <+> pretty h0
liftIO $ assertBool (show $ "hash eq" <+> pretty h0 <+> pretty lbs1) (h0 == lbs1)
entry $ bindMatch "test:ncq3:storage:basic" $ nil_ $ \e -> do entry $ bindMatch "test:ncq3:storage:basic" $ nil_ $ \e -> do