{-# 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)

------------------------------------------------------------------------
-- Signal handling

type Signal = CInt

maxSig :: Int
maxSig :: Int
maxSig = Int
64

type HandlerFun = 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  IOArray Int (Maybe (HandlerFun, Dynamic))
arr <- forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
maxSig) forall a. Maybe a
Nothing
  MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
m <- forall a. a -> IO (MVar a)
newMVar IOArray Int (Maybe (HandlerFun, Dynamic))
arr
  forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
m 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Signal
sig
  forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
signal_handlers forall a b. (a -> b) -> a -> b
$ \IOArray Int (Maybe (HandlerFun, Dynamic))
arr ->
    if Bool -> Bool
not (forall a. Ix a => (a, a) -> a -> Bool
inRange (forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr) Int
int)
      then forall a. [Char] -> a
errorWithoutStackTrace [Char]
"GHC.Conc.setHandler: signal out of range"
      else do Maybe (HandlerFun, Dynamic)
old <- forall i e. IOArray i e -> Int -> IO e
unsafeReadIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr Int
int
              forall i e. IOArray i e -> Int -> e -> IO ()
unsafeWriteIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr Int
int Maybe (HandlerFun, Dynamic)
handler
              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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Signal
sig
  forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (IOArray Int (Maybe (HandlerFun, Dynamic)))
signal_handlers forall a b. (a -> b) -> a -> b
$ \IOArray Int (Maybe (HandlerFun, Dynamic))
arr ->
    if Bool -> Bool
not (forall a. Ix a => (a, a) -> a -> Bool
inRange (forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (HandlerFun, Dynamic))
arr) Int
int)
      then forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else do Maybe (HandlerFun, Dynamic)
handler <- 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 -> 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)
                                  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 = do
  ForeignPtr Word8
fp <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr 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 =
  forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    StablePtr a
stable_ref <- forall a. a -> IO (StablePtr a)
newStablePtr a
a
    let ref :: Ptr b
ref = forall a b. Ptr a -> Ptr b
castPtr (forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stable_ref)
    Ptr a
ref2 <- Ptr a -> IO (Ptr a)
get_or_set forall {b}. Ptr b
ref
    if forall {b}. Ptr b
ref forall a. Eq a => a -> a -> Bool
== Ptr a
ref2
      then forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      else do forall a. StablePtr a -> IO ()
freeStablePtr StablePtr a
stable_ref
              forall a. StablePtr a -> IO a
deRefStablePtr (forall a. Ptr () -> StablePtr a
castPtrToStablePtr (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ref2))