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