As the only blocking operation now is threadDelaySeconds, no need to
calculate actual time and actual expected minimum size.
This commit is contained in:
Joey Hess 2020-12-17 12:09:49 -04:00
parent 2abda21123
commit 26aad24fd3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38

View file

@ -31,7 +31,6 @@ import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM hiding (check) import Control.Concurrent.STM hiding (check)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Data.Time.Clock.POSIX
import System.Log.Logger (debugM) import System.Log.Logger (debugM)
import qualified Data.Map as M import qualified Data.Map as M
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -183,7 +182,6 @@ detectStalls Nothing _ _ = noop
detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing
where where
go st = do go st = do
starttm <- getPOSIXTime
threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration))) threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration)))
-- Get whatever progress value was reported last, if any. -- Get whatever progress value was reported last, if any.
v <- atomically $ fmap fromBytesProcessed v <- atomically $ fmap fromBytesProcessed
@ -198,15 +196,8 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin
-- started and is at a smaller value than -- started and is at a smaller value than
-- the previous one. -- the previous one.
| prev > sofar -> cont | prev > sofar -> cont
| otherwise -> do | sofar - prev < minsz -> onstall
endtm <- getPOSIXTime | otherwise -> cont
let actualduration = endtm - starttm
let sz = sofar - prev
let expectedsz = (minsz * durationSeconds duration)
`div` max 1 (ceiling actualduration)
if sz < expectedsz
then onstall
else cont
{- Starts a new git-annex transfer process, setting up handles {- Starts a new git-annex transfer process, setting up handles
- that will be used to communicate with it. -} - that will be used to communicate with it. -}