diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index f51d0ad0..7b3bd6d2 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -1121,8 +1121,9 @@ theDict = do che <- ContT withGitCat pure $ gitReadObjectMaybe che - out <- newTQueueIO - r <- ContT $ withAsync $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do + + new_ <- newTVarIO mempty + lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do (_,self) <- gitCatBatchQ commit >>= orThrow (GitReadError (show $ pretty commit)) @@ -1131,19 +1132,35 @@ theDict = do hashes <- gitReadTreeObjectsOnly commit <&> ([commit,tree]<>) - >>= filterM req + -- >>= filterM req - atomically $ mapM_ (writeTQueue out) hashes + atomically $ modifyTVar new_ (HS.union (HS.fromList hashes)) - fix \next -> do - h' <- atomically do - pollSTM r >>= \case - Just{} -> pure Nothing - Nothing -> readTQueue out <&> Just - maybe1 h' none $ \h ->do - liftIO $ print $ pretty h - next + fps <- lift $ listObjectIndexFiles + <&> fmap fst + >>= liftIO . mapM (`mmapFileByteString` Nothing) + + allHashes <- readTVarIO new_ + newHashes <- newTVarIO mempty + for_ fps $ \mmaped -> do + for_ allHashes $ \ha -> do + found <- binarySearchBS 56 ( BS.take 20 . BS.drop 4) (coerce ha) mmaped + when (isNothing found) do + atomically $ modifyTVar newHashes (HS.insert ha) + + readTVarIO newHashes >>= liftIO . print . pretty . HS.size + -- liftIO $ print $ pretty (HS + + -- fix \next -> do + -- h' <- atomically do + -- pollSTM r >>= \case + -- Just{} -> pure Nothing + -- Nothing -> readTQueue out <&> Just + + -- maybe1 h' none $ \h ->do + -- liftIO $ print $ pretty h + -- next entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift $ connectedDo do let (opts, argz) = splitOpts [("--index",1),("--ref",1)] syn diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index c495532f..f82f4e88 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -101,37 +101,37 @@ startReflogIndexQueryQueue rq = flip runContT pure do mmaped <- liftIO $ for files (liftIO . flip mmapFileByteString Nothing) - r <- newTVarIO (mempty :: HashMap N.ByteString N.ByteString) + -- r <- newTVarIO (mempty :: HashMap N.ByteString N.ByteString) - -- FIXME: may-explode - for_ mmaped $ \bs -> do - scanBS bs $ \segment -> do - let ha = BS.take 20 segment & coerce - atomically $ modifyTVar r (HM.insert ha segment) + -- -- FIXME: may-explode + -- liftIO $ forConcurrently_ mmaped $ \bs -> do + -- scanBS bs $ \segment -> do + -- let ha = BS.take 20 segment & coerce + -- atomically $ modifyTVar r (HM.insert ha segment) - forever do - (s, f, answ) <- atomically $ readTQueue rq - found <- readTVarIO r <&> HM.lookup s - - atomically do - case found of - Nothing -> writeTMVar answ Nothing - Just x -> writeTMVar answ (Just (f x)) - - -- forever $ liftIO do + -- forever do -- (s, f, answ) <- atomically $ readTQueue rq + -- found <- readTVarIO r <&> HM.lookup s - -- found <- forConcurrently mmaped $ \bs -> runMaybeT do - -- -- FIXME: size-hardcodes - -- w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs - -- >>= toMPlus + -- atomically do + -- case found of + -- Nothing -> writeTMVar answ Nothing + -- Just x -> writeTMVar answ (Just (f x)) - -- let v = BS.drop ( w * 56 ) bs + forever $ liftIO do + (s, f, answ) <- atomically $ readTQueue rq - -- pure $ f v + found <- forConcurrently mmaped $ \bs -> runMaybeT do + -- FIXME: size-hardcodes + w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs + >>= toMPlus - -- let what = headMay (catMaybes found) - -- atomically $ writeTMVar answ what + let v = BS.drop ( w * 56 ) bs + + pure $ f v + + let what = headMay (catMaybes found) + atomically $ writeTMVar answ what writeReflogIndex :: forall m . ( Git3Perks m , MonadReader Git3Env m