module GHC.Conc.Signal
( Signal
, HandlerFun
, setHandler
, runHandlers
) where
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Data.Dynamic (Dynamic)
import Data.Maybe (Maybe(..))
import Foreign.C.Types (CInt)
import Foreign.ForeignPtr (ForeignPtr)
import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr,
deRefStablePtr, freeStablePtr, newStablePtr)
import Foreign.Ptr (Ptr, castPtr)
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 = 64
type HandlerFun = ForeignPtr Word8 -> IO ()
signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
signal_handlers = unsafePerformIO $ do
arr <- newIOArray (0, maxSig) Nothing
m <- newMVar arr
sharedCAF m getOrSetGHCConcSignalSignalHandlerStore
foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore"
getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a)
setHandler :: Signal -> Maybe (HandlerFun, Dynamic)
-> IO (Maybe (HandlerFun, Dynamic))
setHandler sig handler = do
let int = fromIntegral sig
withMVar signal_handlers $ \arr ->
if not (inRange (boundsIOArray arr) int)
then error "GHC.Conc.setHandler: signal out of range"
else do old <- unsafeReadIOArray arr int
unsafeWriteIOArray arr int handler
return old
runHandlers :: ForeignPtr Word8 -> Signal -> IO ()
runHandlers p_info sig = do
let int = fromIntegral sig
withMVar signal_handlers $ \arr ->
if not (inRange (boundsIOArray arr) int)
then return ()
else do handler <- unsafeReadIOArray arr int
case handler of
Nothing -> return ()
Just (f,_) -> do _ <- forkIO (f p_info)
return ()
sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF a get_or_set =
mask_ $ 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))
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4