    {-# 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 = 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 (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 (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 (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 (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 <- 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
    $ 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 (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))