{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
module GHC.Conc.Signal
( Signal
, HandlerFun
, setHandler
, runHandlers
, runHandlersPtr
) where
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Data.Dynamic (Dynamic)
import Foreign.C.Types (CInt)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr)
import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr,
deRefStablePtr, freeStablePtr, newStablePtr)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Marshal.Alloc (finalizerFree)
import GHC.Arr (inRange)
import GHC.Base
import GHC.Conc.Sync (forkIO)
import GHC.IO (mask_, unsafePerformIO)
import GHC.IOArray (IOArray, boundsIOArray, newIOArray,
unsafeReadIOArray, unsafeWriteIOArray)
import GHC.Real (fromIntegral)
import GHC.Word (Word8)
type Signal = CInt
maxSig :: Int
maxSig :: Int
maxSig = Int
64
type HandlerFun = ForeignPtr Word8 -> IO ()
signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
signal_handlers = IO (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
forall a. IO a -> a
unsafePerformIO (IO (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> IO (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
forall a b. (a -> b) -> a -> b
$ do
IOArray Int (Maybe (HandlerFun, Dynamic))
arr <- (Int, Int)
-> Maybe (HandlerFun, Dynamic)
-> IO (IOArray Int (Maybe (HandlerFun, Dynamic)))
forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
maxSig) Maybe (HandlerFun, Dynamic)
forall a. Maybe a
Nothing
MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
m <- IOArray Int (Maybe (HandlerFun, Dynamic))
-> IO (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
forall a. a -> IO (MVar a)
newMVar IOArray Int (Maybe (HandlerFun, Dynamic))
arr
MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
-> (Ptr (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> IO (Ptr (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))))
-> IO (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
m Ptr (MVar (IOArray Int (Maybe (HandlerFun, Dynamic))))
-> IO (Ptr (MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))))
forall a. Ptr a -> IO (Ptr a)
getOrSetGHCConcSignalSignalHandlerStore
{-# NOINLINE signal_handlers #-}
foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore"
getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a)
setHandler :: Signal -> Maybe (HandlerFun, Dynamic)
-> IO (Maybe (HandlerFun, Dynamic))
setHandler :: Signal
-> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
setHandler Signal
sig Maybe (HandlerFun, Dynamic)
handler = do
let int :: Int
int = Signal -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Signal
sig
MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
-> (IOArray Int (Maybe (HandlerFun, Dynamic))
-> IO (Maybe (HandlerFun, Dynamic)))
-> IO (Maybe (HandlerFun, Dynamic))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
signal_handlers ((IOArray Int (Maybe (HandlerFun, Dynamic))
-> IO (Maybe (HandlerFun, Dynamic)))
-> IO (Maybe (HandlerFun, Dynamic)))
-> (IOArray Int (Maybe (HandlerFun, Dynamic))
-> IO (Maybe (HandlerFun, Dynamic)))
-> IO (Maybe (HandlerFun, Dynamic))
forall a b. (a -> b) -> a -> b
$ \IOArray Int (Maybe (HandlerFun, Dynamic))
arr ->
if Bool -> Bool
not ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (IOArray Int (Maybe (HandlerFun, Dynamic)) -> (Int, Int)
forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr) Int
int)
then [Char] -> IO (Maybe (HandlerFun, Dynamic))
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"GHC.Conc.setHandler: signal out of range"
else do Maybe (HandlerFun, Dynamic)
old <- IOArray Int (Maybe (HandlerFun, Dynamic))
-> Int -> IO (Maybe (HandlerFun, Dynamic))
forall i e. IOArray i e -> Int -> IO e
unsafeReadIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr Int
int
IOArray Int (Maybe (HandlerFun, Dynamic))
-> Int -> Maybe (HandlerFun, Dynamic) -> IO ()
forall i e. IOArray i e -> Int -> e -> IO ()
unsafeWriteIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr Int
int Maybe (HandlerFun, Dynamic)
handler
Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HandlerFun, Dynamic)
old
runHandlers :: ForeignPtr Word8 -> Signal -> IO ()
runHandlers :: ForeignPtr Word8 -> Signal -> IO ()
runHandlers ForeignPtr Word8
p_info Signal
sig = do
let int :: Int
int = Signal -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Signal
sig
MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
-> (IOArray Int (Maybe (HandlerFun, Dynamic)) -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
signal_handlers ((IOArray Int (Maybe (HandlerFun, Dynamic)) -> IO ()) -> IO ())
-> (IOArray Int (Maybe (HandlerFun, Dynamic)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOArray Int (Maybe (HandlerFun, Dynamic))
arr ->
if Bool -> Bool
not ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (IOArray Int (Maybe (HandlerFun, Dynamic)) -> (Int, Int)
forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr) Int
int)
then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do Maybe (HandlerFun, Dynamic)
handler <- IOArray Int (Maybe (HandlerFun, Dynamic))
-> Int -> IO (Maybe (HandlerFun, Dynamic))
forall i e. IOArray i e -> Int -> IO e
unsafeReadIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr Int
int
case Maybe (HandlerFun, Dynamic)
handler of
Maybe (HandlerFun, Dynamic)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (HandlerFun
f,Dynamic
_) -> do ThreadId
_ <- IO () -> IO ThreadId
forkIO (HandlerFun
f ForeignPtr Word8
p_info)
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runHandlersPtr :: Ptr Word8 -> Signal -> IO ()
runHandlersPtr :: Ptr Word8 -> Signal -> IO ()
runHandlersPtr Ptr Word8
p Signal
s = do
ForeignPtr Word8
fp <- FinalizerPtr Word8 -> Ptr Word8 -> IO (ForeignPtr Word8)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr Word8
forall a. FinalizerPtr a
finalizerFree Ptr Word8
p
ForeignPtr Word8 -> Signal -> IO ()
runHandlers ForeignPtr Word8
fp Signal
s
sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF :: forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF a
a Ptr a -> IO (Ptr a)
get_or_set =
IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
StablePtr a
stable_ref <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
a
let ref :: Ptr b
ref = Ptr () -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stable_ref)
Ptr a
ref2 <- Ptr a -> IO (Ptr a)
get_or_set Ptr a
forall {b}. Ptr b
ref
if Ptr a
forall {b}. Ptr b
ref Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
ref2
then a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
else do StablePtr a -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr a
stable_ref
StablePtr a -> IO a
forall a. StablePtr a -> IO a
deRefStablePtr (Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
castPtrToStablePtr (Ptr a -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ref2))