summaryrefslogtreecommitdiff
path: root/Utility/ThreadScheduler.hs
diff options
context:
space:
mode:
authorJoey Hess <joeyh@debian.org>2013-11-22 11:16:03 -0400
committerJoey Hess <joeyh@debian.org>2013-11-22 11:16:03 -0400
commit7e592e1d6ed5e0b25b37215da7558c6324688d6f (patch)
tree75a86ff02e9311bcff817f2dcfe9b0a6ca1b5708 /Utility/ThreadScheduler.hs
downloadgit-repair-7e592e1d6ed5e0b25b37215da7558c6324688d6f.tar.gz
git-repair (1.20131122) unstable; urgency=low
* Added test mode, which can be used to randomly corrupt test repositories, in reproducible ways, which allows easy corruption-driven-development. * Improve repair code in the case where the index file is corrupt, and this hides other problems. * Write a dummy .git/HEAD if the file is missing or corrupt, as git otherwise will not treat the repository as a git repo. * Improve fsck code to find badly corrupted objects that crash git fsck before it can complain about them. * Fixed crashes on bad file encodings. * Can now run 10000 tests (git-repair --test -n 10000 --force) with 0 failures. # imported from the archive
Diffstat (limited to 'Utility/ThreadScheduler.hs')
-rw-r--r--Utility/ThreadScheduler.hs69
1 files changed, 69 insertions, 0 deletions
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
new file mode 100644
index 0000000..c3e871c
--- /dev/null
+++ b/Utility/ThreadScheduler.hs
@@ -0,0 +1,69 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Bas van Dijk & Roel van Dijk
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.ThreadScheduler where
+
+import Common
+
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#ifndef __ANDROID__
+import System.Posix.Terminal
+#endif
+#endif
+
+newtype Seconds = Seconds { fromSeconds :: Int }
+ deriving (Eq, Ord, Show)
+
+type Microseconds = Integer
+
+{- Runs an action repeatedly forever, sleeping at least the specified number
+ - of seconds in between. -}
+runEvery :: Seconds -> IO a -> IO a
+runEvery n a = forever $ do
+ threadDelaySeconds n
+ a
+
+threadDelaySeconds :: Seconds -> IO ()
+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
+
+{- Like threadDelay, but not bounded by an Int.
+ -
+ - There is no guarantee that the thread will be rescheduled promptly when the
+ - delay has expired, but the thread will never continue to run earlier than
+ - specified.
+ -
+ - Taken from the unbounded-delay package to avoid a dependency for 4 lines
+ - of code.
+ -}
+unboundDelay :: Microseconds -> IO ()
+unboundDelay time = do
+ let maxWait = min time $ toInteger (maxBound :: Int)
+ threadDelay $ fromInteger maxWait
+ when (maxWait /= time) $ unboundDelay (time - maxWait)
+
+{- Pauses the main thread, letting children run until program termination. -}
+waitForTermination :: IO ()
+waitForTermination = do
+ lock <- newEmptyMVar
+#ifndef mingw32_HOST_OS
+ let check sig = void $
+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ check softwareTermination
+#ifndef __ANDROID__
+ whenM (queryTerminal stdInput) $
+ check keyboardSignal
+#endif
+#endif
+ takeMVar lock
+
+oneSecond :: Microseconds
+oneSecond = 1000000