1 files changed, 40 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/should_run/conc022.hs b/testsuite/tests/concurrent/should_run/conc022.hs
new file mode 100644
index 0000000000..5d420d8af7
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/conc022.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE MagicHash #-}
+-- !!! test tryTakeMVar
+
+import Control.Concurrent
+import Control.Exception
+
+import GHC.Exts		( fork# )
+import GHC.IO    	( IO(..) )
+import GHC.Conc		( ThreadId(..) )
+
+main = do
+  m <- newEmptyMVar
+  r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
+  print (r :: Maybe Int)
+
+  m <- newMVar True
+  r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
+  print r
+
+timeout
+   :: Int	-- secs
+   -> IO a	-- action to run
+   -> IO a	-- action to run on timeout
+   -> IO a
+
+timeout secs action on_timeout 
+  = do
+    threadid <- myThreadId
+    timeout <- forkIO $ do threadDelay (secs * 1000000)
+                           throwTo threadid (ErrorCall "__timeout")
+    ( do result <- action
+	 killThread timeout
+	 return result
+      ) 
+      `Control.Exception.catch`
+        \exception -> case fromException exception of
+		       Just (ErrorCall "__timeout") -> on_timeout
+		       _other -> do killThread timeout
+                                    throw exception
+