851c4bb72c7ec205df7e39a8cbb37b4506ba38b3
[packages/base.git] / GHC / Conc / Signal.hs
1 {-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-}
2
3 module GHC.Conc.Signal
4 ( Signal
5 , HandlerFun
6 , setHandler
7 , runHandlers
8 ) where
9
10 import Control.Concurrent.MVar (MVar, newMVar, withMVar)
11 import Data.Dynamic (Dynamic)
12 import Data.Maybe (Maybe(..))
13 import Foreign.C.Types (CInt)
14 import Foreign.ForeignPtr (ForeignPtr)
15 import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr,
16 deRefStablePtr, freeStablePtr, newStablePtr)
17 import Foreign.Ptr (Ptr, castPtr)
18 import GHC.Arr (inRange)
19 import GHC.Base
20 import GHC.Conc.Sync (forkIO)
21 import GHC.IO (mask_, unsafePerformIO)
22 import GHC.IOArray (IOArray, boundsIOArray, newIOArray, unsafeReadIOArray,
23 unsafeWriteIOArray)
24 import GHC.Real (fromIntegral)
25 import GHC.Word (Word8)
26
27 ------------------------------------------------------------------------
28 -- Signal handling
29
30 type Signal = CInt
31
32 maxSig :: Int
33 maxSig = 64
34
35 type HandlerFun = ForeignPtr Word8 -> IO ()
36
37 -- Lock used to protect concurrent access to signal_handlers. Symptom
38 -- of this race condition is GHC bug #1922, although that bug was on
39 -- Windows a similar bug also exists on Unix.
40 signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
41 signal_handlers = unsafePerformIO $ do
42 arr <- newIOArray (0, maxSig) Nothing
43 m <- newMVar arr
44 sharedCAF m getOrSetGHCConcSignalSignalHandlerStore
45 {-# NOINLINE signal_handlers #-}
46
47 foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore"
48 getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a)
49
50 setHandler :: Signal -> Maybe (HandlerFun, Dynamic)
51 -> IO (Maybe (HandlerFun, Dynamic))
52 setHandler sig handler = do
53 let int = fromIntegral sig
54 withMVar signal_handlers $ \arr ->
55 if not (inRange (boundsIOArray arr) int)
56 then error "GHC.Conc.setHandler: signal out of range"
57 else do old <- unsafeReadIOArray arr int
58 unsafeWriteIOArray arr int handler
59 return old
60
61 runHandlers :: ForeignPtr Word8 -> Signal -> IO ()
62 runHandlers p_info sig = do
63 let int = fromIntegral sig
64 withMVar signal_handlers $ \arr ->
65 if not (inRange (boundsIOArray arr) int)
66 then return ()
67 else do handler <- unsafeReadIOArray arr int
68 case handler of
69 Nothing -> return ()
70 Just (f,_) -> do _ <- forkIO (f p_info)
71 return ()
72
73 -- Machinery needed to ensure that we only have one copy of certain
74 -- CAFs in this module even when the base package is present twice, as
75 -- it is when base is dynamically loaded into GHCi. The RTS keeps
76 -- track of the single true value of the CAF, so even when the CAFs in
77 -- the dynamically-loaded base package are reverted, nothing bad
78 -- happens.
79 --
80 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
81 sharedCAF a get_or_set =
82 mask_ $ do
83 stable_ref <- newStablePtr a
84 let ref = castPtr (castStablePtrToPtr stable_ref)
85 ref2 <- get_or_set ref
86 if ref == ref2
87 then return a
88 else do freeStablePtr stable_ref
89 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
90