X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=57500f4a3f0899ef81be2731045692d58103a706;hb=b40cf1d33ed4f7da5b4edf0eff8251d30e32f137;hp=eac470beddf1c5f2f5d52753f81ebbb67f3d6bab;hpb=c32b545138f37d8455fd2dbd6d70eeb5c9e8b085;p=ghc-base.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index eac470b..57500f4 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -765,19 +765,33 @@ data DelayReq
   | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
 
 #ifndef mingw32_HOST_OS
+{-# NOINLINE pendingEvents #-}
 pendingEvents :: IORef [IOReq]
+pendingEvents = unsafePerformIO $ do
+   m <- newIORef []
+   sharedCAF m getOrSetGHCConcPendingEventsStore
+
+foreign import ccall unsafe "getOrSetGHCConcPendingEventsStore"
+    getOrSetGHCConcPendingEventsStore :: Ptr a -> IO (Ptr a)
 #endif
-pendingDelays :: IORef [DelayReq]
-{-# NOINLINE pendingEvents #-}
+
 {-# NOINLINE pendingDelays #-}
-(pendingEvents,pendingDelays) = unsafePerformIO $ do
-  reqs <- newIORef []
-  dels <- newIORef []
-  return (reqs, dels)
+pendingDelays :: IORef [DelayReq]
+pendingDelays = unsafePerformIO $ do
+   m <- newIORef []
+   sharedCAF m getOrSetGHCConcPendingDelaysStore
+
+foreign import ccall unsafe "getOrSetGHCConcPendingDelaysStore"
+    getOrSetGHCConcPendingDelaysStore :: Ptr a -> IO (Ptr a)
 
 {-# NOINLINE ioManagerThread #-}
 ioManagerThread :: MVar (Maybe ThreadId)
-ioManagerThread = unsafePerformIO $ newMVar Nothing
+ioManagerThread = unsafePerformIO $ do
+   m <- newMVar Nothing
+   sharedCAF m getOrSetGHCConcIOManagerThreadStore
+
+foreign import ccall unsafe "getOrSetGHCConcIOManagerThreadStore"
+    getOrSetGHCConcIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 
 ensureIOManagerIsRunning :: IO ()
 ensureIOManagerIsRunning 
@@ -812,15 +826,40 @@ type USecs = Word64
 foreign import ccall unsafe "getUSecOfDay" 
   getUSecOfDay :: IO USecs
 
-prodding :: IORef Bool
 {-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newIORef False)
+prodding :: IORef Bool
+prodding = unsafePerformIO $ do
+   r <- newIORef False
+   sharedCAF r getOrSetGHCConcProddingStore
+
+foreign import ccall unsafe "getOrSetGHCConcProddingStore"
+    getOrSetGHCConcProddingStore :: Ptr a -> IO (Ptr a)
 
 prodServiceThread :: IO ()
 prodServiceThread = do
-  was_set <- atomicModifyIORef prodding (\a -> (True,a))
+  was_set <- readIORef prodding
+  writeIORef prodding True
+     -- no need for atomicModifyIORef, extra prods are harmless.
   if (not (was_set)) then wakeupIOManager else return ()
 
+-- Machinery needed to ensure that we only have one copy of certain
+-- CAFs in this module even when the base package is present twice, as
+-- it is when base is dynamically loaded into GHCi.  The RTS keeps
+-- track of the single true value of the CAF, so even when the CAFs in
+-- the dynamically-loaded base package are reverted, nothing bad
+-- happens.
+--
+sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
+sharedCAF a get_or_set =
+   block $ do
+     stable_ref <- newStablePtr a
+     let ref = castPtr (castStablePtrToPtr stable_ref)
+     ref2 <- get_or_set ref
+     if ref==ref2
+        then return a
+        else do freeStablePtr stable_ref
+                deRefStablePtr (castPtrToStablePtr (castPtr ref2))
+
 #ifdef mingw32_HOST_OS
 -- ----------------------------------------------------------------------------
 -- Windows IO manager thread
@@ -958,7 +997,6 @@ ioManager = do
                                      -- don't want them to block.
         setCloseOnExec rd_end
         setCloseOnExec wr_end
-        writeIORef stick (fromIntegral wr_end)
         c_setIOManagerPipe wr_end
         allocaBytes sizeofFdSet   $ \readfds -> do
         allocaBytes sizeofFdSet   $ \writefds -> do 
@@ -1058,11 +1096,6 @@ io_MANAGER_WAKEUP = 0xff
 io_MANAGER_DIE    = 0xfe
 io_MANAGER_SYNC   = 0xfd
 
--- | the stick is for poking the IO manager with
-stick :: IORef Fd
-{-# NOINLINE stick #-}
-stick = unsafePerformIO $ newIORef (-1)
-
 {-# NOINLINE sync #-}
 sync :: IORef [MVar ()]
 sync = unsafePerformIO (newIORef [])
@@ -1072,18 +1105,11 @@ syncIOManager :: IO ()
 syncIOManager = do
   m <- newEmptyMVar
   atomicModifyIORef sync (\old -> (m:old,()))
-  fd <- readIORef stick
-  when (fd /= (-1)) $
-    with io_MANAGER_SYNC $ \pbuf -> do
-      warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1
+  c_ioManagerSync
   takeMVar m
 
-wakeupIOManager :: IO ()
-wakeupIOManager = do
-  fd <- readIORef stick
-  when (fd /= (-1)) $
-    with io_MANAGER_WAKEUP $ \pbuf -> do
-      warnErrnoIfMinus1_ "wakeupIOManager" $ c_write (fromIntegral fd) pbuf 1
+foreign import ccall unsafe "ioManagerSync"   c_ioManagerSync :: IO ()
+foreign import ccall unsafe "ioManagerWakeup" wakeupIOManager :: IO ()
 
 -- For the non-threaded RTS
 runHandlers :: Ptr Word8 -> Int -> IO ()
@@ -1137,17 +1163,10 @@ signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
 signal_handlers = unsafePerformIO $ do
    arr <- newIOArray (0,maxSig) Nothing
    m <- newMVar arr
-   block $ do
-     stable_ref <- newStablePtr m
-     let ref = castStablePtrToPtr stable_ref
-     ref2 <- getOrSetSignalHandlerStore ref
-     if ref==ref2
-        then return m
-        else do freeStablePtr stable_ref
-                deRefStablePtr (castPtrToStablePtr ref2)
+   sharedCAF m getOrSetGHCConcSignalHandlerStore
 
-foreign import ccall unsafe "getOrSetSignalHandlerStore"
-    getOrSetSignalHandlerStore :: Ptr a -> IO (Ptr a)
+foreign import ccall unsafe "getOrSetGHCConcSignalHandlerStore"
+    getOrSetGHCConcSignalHandlerStore :: Ptr a -> IO (Ptr a)
 
 setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic))
 setHandler sig handler = do