diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index e080b487..ce6d4a2c 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -1011,6 +1011,9 @@ theDict = do _already <- newTVarIO mempty + level <- getCompressionLevel + segment <- getPackedSegmetSize + let notWrittenYet :: forall m . MonadIO m => GitHash -> m Bool notWrittenYet x = do @@ -1031,6 +1034,7 @@ theDict = do & fmap (view _1) let total = HPSQ.size hpsq + bytes_ <- newTVarIO 0 debug $ "TOTAL" <+> pretty total @@ -1038,13 +1042,18 @@ theDict = do tn <- getNumCapabilities - sourceQ <- newTBQueueIO (fromIntegral tn * 100) + sourceQ <- newTBQueueIO (fromIntegral tn * 10) + + + let write sz_ fh ss = do + LBS.hPutStr fh ss + atomically $ modifyTVar sz_ (+ LBS.length ss) l <- lift $ async $ do flip fix ECCInit $ \loop -> \case ECCInit -> do - zstd <- ZstdS.compress maxCLevel + zstd <- ZstdS.compress level seed <- randomIO @Word16 let fn = show $ "export-" <> pretty seed <> ".log" logFile <- IO.openBinaryFile fn WriteMode @@ -1061,18 +1070,16 @@ theDict = do lbs <- S.toList_ (writeSection s $ S.yield) <&> mconcat sz_ <- newTVarIO 0 - let write ss = do - LBS.hPutStr fh ss - atomically $ modifyTVar sz_ (+ LBS.length ss) - sn1 <- writeCompressedChunkZstd write sn (Just lbs) + sn1 <- writeCompressedChunkZstd (write sz_ fh) sn (Just lbs) sz <- readTVarIO sz_ <&> fromIntegral + atomically $ modifyTVar bytes_ (+ fromIntegral sz) loop (ECCWrite (bnum + sz) fh sn1) ECCFinalize again fh sn -> do - void $ writeCompressedChunkZstd (LBS.hPutStr fh) sn Nothing + void $ writeCompressedChunkZstd (write bytes_ fh) sn Nothing hClose fh when again $ loop ECCInit @@ -1113,15 +1120,42 @@ theDict = do atomically do writeTBQueue sourceQ (Just e) - ContT $ withAsync $ forever do - pause @'Seconds 1 - p <- readTVarIO progress_ + t0 <- getTimeCoarse + ContT $ withAsync $ do - let pp = fromIntegral p / (fromIntegral total :: Double) * 100 + liftIO $ hPrint stderr $ + "segment" <+> pretty segment <> comma + <> "compression level" <+> pretty level + + flip fix (t0,0) $ \next (tPrev,bytesPrev) -> do + + pause @'Seconds 1 + + p <- readTVarIO progress_ + b <- readTVarIO bytes_ + + let pp = fromIntegral p / (fromIntegral total :: Double) * 100 + & realToFrac @_ @(Fixed E2) + + t1 <- getTimeCoarse + + let dt = realToFrac @_ @Double (t1 - tPrev) * 1e-9 & realToFrac @_ @(Fixed E2) - liftIO $ IO.hPutStr stderr $ show $ " \r" <> pretty pp <> "%" - pure () + let tspent = realToFrac (t1 - t0) * 1e-9 & realToFrac @_ @(Fixed E2) + + let mbytes = realToFrac b / 1024/1024 & realToFrac @_ @(Fixed E2) + + let dbdt = mbytes / tspent + + liftIO $ IO.hPutStr stderr $ show $ + " \r" + <+> pretty tspent <> "s" + <+> pretty mbytes <> "mb" + <+> pretty dbdt <> "mbs" + <+> pretty pp <> "%" + + next (t1,b) mapM_ link workers mapM_ wait workers