From 500ad351a5ef1b994cf62e515b3d5bd31201b143 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 20 Aug 2025 13:13:25 +0300 Subject: [PATCH] bytestring offloading --- .../lib/HBS2/Storage/NCQ3/Internal.hs | 41 ++++++++++++++----- .../lib/HBS2/Storage/NCQ3/Internal/Index.hs | 10 +++-- .../HBS2/Storage/NCQ3/Internal/Memtable.hs | 8 ++-- .../lib/HBS2/Storage/NCQ3/Internal/Run.hs | 9 ++-- .../lib/HBS2/Storage/NCQ3/Internal/Types.hs | 23 +++++++---- hbs2-tests/test/NCQ3.hs | 1 - .../Data/Config/Suckless/Script/Internal.hs | 2 +- 7 files changed, 63 insertions(+), 31 deletions(-) diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs index 00cfd3f9..e6ff48ca 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs @@ -1,4 +1,5 @@ {-# Language RecordWildCards #-} +{-# Language MultiWayIf #-} module HBS2.Storage.NCQ3.Internal where import HBS2.Storage.NCQ3.Internal.Prelude @@ -170,13 +171,19 @@ ncqPutBS0 wait ncq@NCQStorage{..} mtp mhref bs' = ncqOperation ncq (pure $ fromM let work = do let bs = ncqMakeSectionBS mtp h bs' let shard = ncqGetShard ncq h - zero <- newTVarIO Nothing atomically do - upd <- stateTVar shard $ flip HM.alterF h \case - Nothing -> (True, Just (NCQEntry bs zero)) - Just e | ncqEntryData e /= bs -> (True, Just (NCQEntry bs zero)) - | otherwise -> (False, Just e) + upd <- readTVar shard <&> HM.lookup h >>= \case + Nothing -> do + here <- newTVar (EntryHere bs) + modifyTVar shard (HM.insert h (NCQEntry here)) + pure True + + Just (NCQEntry e) -> readTVar e >>= \case + EntryHere bs'' | bs == bs''-> pure False + | otherwise -> writeTVar e (EntryHere bs) >> pure True + + EntryThere{} -> writeTVar e (EntryHere bs) >> pure True when upd do modifyTVar ncqWriteQ (|> h) @@ -287,14 +294,28 @@ instance IsTomb Location where (_, Right (T, _)) -> True _ -> False +instance IsTomb FileLocation where + ncqIsTomb (FileLocation _ _ s) = ncqIsTombEntrySize s + ncqGetEntryBS :: MonadUnliftIO m => NCQStorage -> Location -> m (Maybe ByteString) ncqGetEntryBS me = \case InMemory bs -> pure $ Just bs - InFossil (FileLocation fk off size) -> ncqWithState me $ const do - try @_ @SomeException (ncqGetCachedData me fk) >>= \case - Left e -> err (viaShow e) >> pure Nothing - Right (CachedData mmap) -> do - pure $ Just $ BS.take (fromIntegral size) $ BS.drop (fromIntegral off) mmap + + InFossil l@(FileLocation fk off size) -> flip fix (0 :: Int) \next i -> do + ncqWithState me $ const do + try @_ @SomeException (ncqGetCachedData me fk) >>= \case + Left e -> err (viaShow e) >> pure Nothing + Right (CachedData mmap) -> do + + if | BS.length mmap >= fromIntegral off + fromIntegral size -> do + pure $ Just $ BS.take (fromIntegral size) $ BS.drop (fromIntegral off) mmap + + | i < 1 -> do + atomically (ncqDelCachedDataSTM me fk) >> next (succ i) + + | otherwise -> do + err $ red "can't remap fossil" <+> pretty l + pure Nothing ncqEntrySize :: forall a . Integral a => Location -> a ncqEntrySize = \case 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 47890343..63e9a6c4 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs @@ -130,9 +130,13 @@ ncqIndexFile n ts' fk = runMaybeT do nwayHashScanAll nw bs $ \_ k _ -> do unless (k == emptyKey) $ atomically $ void $ runMaybeT do - NCQEntry _ tfk <- MaybeT $ ncqLookupEntrySTM n (coerce k) - fk' <- MaybeT $ readTVar tfk - guard (coerce fk == flKey fk') -- remove only own stuff + e <- MaybeT $ ncqLookupEntrySTM n (coerce k) + + fk' <- MaybeT $ case snd e of + EntryHere{} -> pure Nothing + EntryThere l -> pure $ Just (flKey l) + + guard (coerce fk == fk') -- remove only own stuff lift $ ncqAlterEntrySTM n (coerce k) (const Nothing) pure dest diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Memtable.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Memtable.hs index 5deb7ef6..3e49e716 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Memtable.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Memtable.hs @@ -18,9 +18,11 @@ ncqGetShard :: NCQStorage -> HashRef -> Shard ncqGetShard ncq@NCQStorage{..} h = ncqMemTable ! ncqShardIdx ncq h {-# INLINE ncqGetShard #-} - -ncqLookupEntrySTM :: NCQStorage -> HashRef -> STM (Maybe NCQEntry) -ncqLookupEntrySTM ncq h = readTVar (ncqGetShard ncq h) <&> HM.lookup h +ncqLookupEntrySTM :: NCQStorage -> HashRef -> STM (Maybe (NCQEntry, NCQEntryL)) +ncqLookupEntrySTM ncq h = readTVar (ncqGetShard ncq h) + <&> HM.lookup h >>= \case + Nothing -> pure Nothing + Just e@(NCQEntry v)-> Just . (e,) <$> readTVar v ncqAlterEntrySTM :: NCQStorage -> HashRef 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 7e948c62..4f4ca9f5 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs @@ -67,7 +67,8 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do atomically (ncqLookupEntrySTM ncq h) >>= \case Nothing -> none - Just e -> answer (Just (InMemory (ncqEntryData e))) >> exit () + Just (_, EntryHere bs) -> answer (Just (InMemory bs)) >> exit () + Just (_, EntryThere loc) -> answer (Just $ InFossil loc) >> exit () ContT $ ncqWithState ncq @@ -195,10 +196,10 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do Just (Right chu) -> do ws <- for chu $ \h -> do atomically (ncqLookupEntrySTM ncq h) >>= \case - Just (NCQEntry bs w) -> do - let off = fromIntegral total' + Just (NCQEntry w, EntryHere bs) -> do + off <- fromIntegral <$> liftIO (fdSeek fh RelativeSeek 0) n <- lift (appendSection fh bs) - atomically (writeTVar w (Just (FileLocation fk off (fromIntegral n)))) + atomically (writeTVar w (EntryThere (FileLocation fk off (fromIntegral n)))) pure n _ -> pure 0 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 4368d47c..3ed9e8df 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs @@ -43,20 +43,21 @@ data FileLocation = } deriving stock (Eq,Ord) - data Location = InFossil {-# UNPACK #-} !FileLocation | InMemory {-# UNPACK #-} !ByteString -data NCQEntry = - NCQEntry - { ncqEntryData :: !ByteString - , ncqDumped :: !(TVar (Maybe FileLocation)) - } +newtype NCQEntry = NCQEntry (TVar NCQEntryL) + -- NCQEntry + -- { ncqEntryData :: !ByteString + -- , ncqDumped :: !(TVar (Maybe FileLocation)) + -- } -type NCQOffset = Word64 +data NCQEntryL = EntryHere !ByteString | EntryThere !FileLocation + +type NCQOffset = Word64 type NCQFileSize = NCQOffset -type NCQSize = Word32 +type NCQSize = Word32 data Fact = P PData -- pending, not indexed deriving stock (Eq,Ord,Data) @@ -151,6 +152,9 @@ instance Semigroup NCQState where facts = ncqStateFacts a <> ncqStateFacts b +instance Pretty FileLocation where + pretty (FileLocation f o s) = parens ("file-location" <+> pretty f <+> pretty o <+> pretty s) + instance Pretty Location where pretty = \case InFossil (FileLocation k o s) -> parens $ "in-fossil" <+> pretty k <+> pretty o <+> pretty s @@ -216,9 +220,10 @@ ncqDeferredWriteOpSTM NCQStorage{..} work = do nw <- readTVar ncqWrites <&> (`mod` V.length ncqWriteOps) writeTQueue (ncqWriteOps ! nw) work +{- HLINT Ignore "Eta reduction"-} + logErr :: forall x a m . (Pretty x, MonadUnliftIO m) => x -> m a -> m a logErr loc m = handle (\(e::SomeException) -> err (pretty loc <> ":" <> viaShow e) >> throwIO e) m - diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index 7b8f68a8..7da8b858 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/hbs2-tests/test/NCQ3.hs @@ -440,7 +440,6 @@ ncq3Tests = do entry $ bindMatch "test:ncq3:concurrent1" $ nil_ $ \case [ LitIntVal tn, LitIntVal n ] -> do - debug $ "ncq2:concurrent1" <+> pretty tn <+> pretty n runTest $ testNCQ3Concurrent1 False ( fromIntegral tn) (fromIntegral n) e -> throwIO $ BadFormException @C (mkList e) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index 26b168fc..c6d6ef9f 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -1423,7 +1423,7 @@ internalEntries = do entry $ bindMatch "coalesce" $ \case [a] -> pure a [a,b] | isFalse b -> pure a - [a,_] -> pure a + | otherwise -> pure b _ -> pure nil entry $ bindAlias "nvl" "coalesce"