mark System.IO.openTempFile as non-portable in haddocks

[haskell-directory.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index bd03295..d6fdd4f 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -98,7 +98,7 @@ import Data.Maybe
 import GHC.Base
 import GHC.IOBase
 import GHC.Num         ( Num(..) )
-import GHC.Real                ( fromIntegral, quot )
+import GHC.Real                ( fromIntegral, div )
 #ifndef mingw32_HOST_OS
 import GHC.Base                ( Int(..) )
 #endif
@@ -146,7 +146,7 @@ instance Show ThreadId where
        showString "ThreadId " . 
         showsPrec d (getThreadId (id2TSO t))
 
-foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> Int
+foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
 
 id2TSO :: ThreadId -> ThreadId#
 id2TSO (ThreadId t) = t
@@ -707,8 +707,8 @@ data IOReq
 #endif
 
 data DelayReq
-  = Delay    {-# UNPACK #-} !Word64 {-# UNPACK #-} !(MVar ())
-  | DelaySTM {-# UNPACK #-} !Word64 {-# UNPACK #-} !(TVar Bool)
+  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
+  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
 
 #ifndef mingw32_HOST_OS
 pendingEvents :: IORef [IOReq]
@@ -736,6 +736,7 @@ insertDelay d1 ds@(d2 : rest)
   | delayTime d1 <= delayTime d2 = d1 : ds
   | otherwise                    = d2 : insertDelay d1 rest
 
+delayTime :: DelayReq -> USecs
 delayTime (Delay t _) = t
 delayTime (DelaySTM t _) = t
 
@@ -748,6 +749,15 @@ atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
 foreign import ccall unsafe "getUSecOfDay" 
   getUSecOfDay :: IO USecs
 
+prodding :: IORef Bool
+{-# NOINLINE prodding #-}
+prodding = unsafePerformIO (newIORef False)
+
+prodServiceThread :: IO ()
+prodServiceThread = do
+  was_set <- atomicModifyIORef prodding (\a -> (True,a))
+  if (not (was_set)) then wakeupIOManager else return ()
+
 #ifdef mingw32_HOST_OS
 -- ----------------------------------------------------------------------------
 -- Windows IO manager thread
@@ -788,8 +798,7 @@ service_loop wakeup old_delays = do
     _other -> service_cont wakeup delays' -- probably timeout        
 
 service_cont wakeup delays = do
-  takeMVar prodding
-  putMVar prodding False
+  atomicModifyIORef prodding (\_ -> (False,False))
   service_loop wakeup delays
 
 -- must agree with rts/win32/ThrIOManager.c
@@ -809,18 +818,9 @@ stick :: IORef HANDLE
 {-# NOINLINE stick #-}
 stick = unsafePerformIO (newIORef nullPtr)
 
-prodding :: MVar Bool
-{-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newMVar False)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
-  b <- takeMVar prodding
-  if (not b) 
-    then do hdl <- readIORef stick
-            c_sendIOManagerEvent io_MANAGER_WAKEUP
-    else return ()
-  putMVar prodding True
+wakeupIOManager = do 
+  hdl <- readIORef stick
+  c_sendIOManagerEvent io_MANAGER_WAKEUP
 
 -- Walk the queue of pending delays, waking up any that have passed
 -- and return the smallest delay to wait for.  The queue of pending
@@ -836,9 +836,10 @@ getDelay now all@(d : rest)
        atomically $ writeTVar t True
        getDelay now rest
      _otherwise ->
-        return (all, (fromIntegral (delayTime d - now) * 
-                        fromIntegral tick_msecs))
-                        -- delay is in millisecs for WaitForSingleObject
+        -- delay is in millisecs for WaitForSingleObject
+        let micro_seconds = delayTime d - now
+            milli_seconds = (micro_seconds + 999) `div` 1000
+        in return (all, fromIntegral milli_seconds)
 
 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
 -- available yet.  We should move some Win32 functionality down here,
@@ -914,7 +915,7 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
          now <- getUSecOfDay
          (delays', timeout) <- getDelay now ptimeval delays
 
-         res <- c_select ((max wakeup maxfd)+1) readfds writefds 
+         res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds 
                        nullPtr timeout
          if (res == -1)
             then do
@@ -952,8 +953,7 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   if exit then return () else do
 
-  takeMVar prodding
-  putMVar prodding False
+  atomicModifyIORef prodding (\_ -> (False,False))
 
   reqs' <- if wakeup_all then do wakeupAll reqs; return []
                         else completeRequests reqs readfds writefds []
@@ -967,19 +967,11 @@ stick :: IORef Fd
 {-# NOINLINE stick #-}
 stick = unsafePerformIO (newIORef 0)
 
-prodding :: MVar Bool
-{-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newMVar False)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
-  b <- takeMVar prodding
-  if (not b) 
-    then do fd <- readIORef stick
-           with io_MANAGER_WAKEUP $ \pbuf -> do 
-               c_write (fromIntegral fd) pbuf 1; return ()
-    else return ()
-  putMVar prodding True
+wakeupIOManager :: IO ()
+wakeupIOManager = do
+  fd <- readIORef stick
+  with io_MANAGER_WAKEUP $ \pbuf -> do 
+    c_write (fromIntegral fd) pbuf 1; return ()
 
 foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))
 
@@ -1073,20 +1065,32 @@ foreign import ccall unsafe "setTimevalTicks"
 newtype CFdSet = CFdSet ()
 
 foreign import ccall safe "select"
-  c_select :: Fd -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
+  c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
            -> IO CInt
 
 foreign import ccall unsafe "hsFD_SETSIZE"
-  fD_SETSIZE :: Fd
+  c_fD_SETSIZE :: CInt
+
+fD_SETSIZE :: Fd
+fD_SETSIZE = fromIntegral c_fD_SETSIZE
 
 foreign import ccall unsafe "hsFD_CLR"
-  fdClr :: Fd -> Ptr CFdSet -> IO ()
+  c_fdClr :: CInt -> Ptr CFdSet -> IO ()
+
+fdClr :: Fd -> Ptr CFdSet -> IO ()
+fdClr (Fd fd) fdset = c_fdClr fd fdset
 
 foreign import ccall unsafe "hsFD_ISSET"
-  fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
+  c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
+
+fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
+fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
 
 foreign import ccall unsafe "hsFD_SET"
-  fdSet :: Fd -> Ptr CFdSet -> IO ()
+  c_fdSet :: CInt -> Ptr CFdSet -> IO ()
+
+fdSet :: Fd -> Ptr CFdSet -> IO ()
+fdSet (Fd fd) fdset = c_fdSet fd fdset
 
 foreign import ccall unsafe "hsFD_ZERO"
   fdZero :: Ptr CFdSet -> IO ()