{-# LANGUAGE Trustworthy #-}{-# LANGUAGE NoImplicitPrelude #-}moduleGHC.Conc.Signal(Signal ,HandlerFun ,setHandler ,runHandlers ,runHandlersPtr )whereimportControl.Concurrent.MVar (MVar ,newMVar ,withMVar )importData.Dynamic (Dynamic )importForeign.C.Types (CInt )importForeign.ForeignPtr (ForeignPtr ,newForeignPtr )importForeign.StablePtr (castPtrToStablePtr ,castStablePtrToPtr ,deRefStablePtr ,freeStablePtr ,newStablePtr )importForeign.Ptr (Ptr ,castPtr )importForeign.Marshal.Alloc (finalizerFree )importGHC.Arr (inRange )importGHC.Base importGHC.Conc.Sync (forkIO )importGHC.IO (mask_ ,unsafePerformIO )importGHC.IOArray (IOArray ,boundsIOArray ,newIOArray ,unsafeReadIOArray ,unsafeWriteIOArray )importGHC.Real (fromIntegral )importGHC.Word (Word8 )-------------------------------------------------------------------------- Signal handlingtypeSignal =CInt maxSig ::Int maxSig :: Int
maxSig =Int
64typeHandlerFun =ForeignPtr Word8 ->IO ()-- Lock used to protect concurrent access to signal_handlers. Symptom-- of this race condition is GHC bug #1922, although that bug was on-- Windows a similar bug also exists on Unix.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
$ doIOArray 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 {-# NOINLINEsignal_handlers #-}foreignimportccallunsafe"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 =doletint :: 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 ->ifBool -> 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"elsedoMaybe (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 =doletint :: 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 ->ifBool -> 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 ()elsedoMaybe (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 caseMaybe (HandlerFun, Dynamic)
handler ofMaybe (HandlerFun, Dynamic)
Nothing ->() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()Just (HandlerFun
f ,Dynamic
_)->doThreadId
_<-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 ()-- It is our responsibility to free the memory buffer, so we create a-- foreignPtr.runHandlersPtr ::Ptr Word8 ->Signal ->IO ()runHandlersPtr :: Ptr Word8 -> Signal -> IO ()
runHandlersPtr Ptr Word8
p Signal
s =doForeignPtr 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 -- 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 :: 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
$ doStablePtr a
stable_ref <-a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
a letref :: 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 ifPtr a
forall {b}. Ptr b
ref Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
ref2 thena -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a elsedoStablePtr 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 ))