GHC/Conc/Signal.hs

   1 {-# LANGUAGE NoImplicitPrelude #-}
   2
   3 module GHC.Conc.Signal
   4         ( Signal
   5         , HandlerFun
   6         , setHandler
   7         , runHandlers
   8         ) where
   9
  10 import Control.Concurrent.MVar (MVar, newMVar, withMVar)
  11 import Data.Dynamic (Dynamic)
  12 import Data.Maybe (Maybe(..))
  13 import Foreign.C.Types (CInt)
  14 import Foreign.ForeignPtr (ForeignPtr)
  15 import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr,
  16                           deRefStablePtr, freeStablePtr, newStablePtr)
  17 import Foreign.Ptr (Ptr, castPtr)
  18 import GHC.Arr (inRange)
  19 import GHC.Base
  20 import GHC.Conc.Sync (forkIO)
  21 import GHC.IO (mask_, unsafePerformIO)
  22 import GHC.IOArray (IOArray, boundsIOArray, newIOArray, unsafeReadIOArray,
  23                     unsafeWriteIOArray)
  24 import GHC.Num (fromInteger)
  25 import GHC.Real (fromIntegral)
  26 import GHC.Word (Word8)
  27
  28 ------------------------------------------------------------------------
  29 -- Signal handling
  30
  31 type Signal = CInt
  32
  33 maxSig :: Int
  34 maxSig = 64
  35
  36 type HandlerFun = ForeignPtr Word8 -> IO ()
  37
  38 -- Lock used to protect concurrent access to signal_handlers.  Symptom
  39 -- of this race condition is GHC bug #1922, although that bug was on
  40 -- Windows a similar bug also exists on Unix.
  41 signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
  42 signal_handlers = unsafePerformIO $ do
  43   arr <- newIOArray (0, maxSig) Nothing
  44   m <- newMVar arr
  45   sharedCAF m getOrSetGHCConcSignalSignalHandlerStore
  46 {-# NOINLINE signal_handlers #-}
  47
  48 foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore"
  49   getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a)
  50
  51 setHandler :: Signal -> Maybe (HandlerFun, Dynamic)
  52            -> IO (Maybe (HandlerFun, Dynamic))
  53 setHandler sig handler = do
  54   let int = fromIntegral sig
  55   withMVar signal_handlers $ \arr ->
  56     if not (inRange (boundsIOArray arr) int)
  57       then error "GHC.Conc.setHandler: signal out of range"
  58       else do old <- unsafeReadIOArray arr int
  59               unsafeWriteIOArray arr int handler
  60               return old
  61
  62 runHandlers :: ForeignPtr Word8 -> Signal -> IO ()
  63 runHandlers p_info sig = do
  64   let int = fromIntegral sig
  65   withMVar signal_handlers $ \arr ->
  66     if not (inRange (boundsIOArray arr) int)
  67       then return ()
  68       else do handler <- unsafeReadIOArray arr int
  69               case handler of
  70                 Nothing -> return ()
  71                 Just (f,_)  -> do _ <- forkIO (f p_info)
  72                                   return ()
  73
  74 -- Machinery needed to ensure that we only have one copy of certain
  75 -- CAFs in this module even when the base package is present twice, as
  76 -- it is when base is dynamically loaded into GHCi.  The RTS keeps
  77 -- track of the single true value of the CAF, so even when the CAFs in
  78 -- the dynamically-loaded base package are reverted, nothing bad
  79 -- happens.
  80 --
  81 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
  82 sharedCAF a get_or_set =
  83   mask_ $ do
  84     stable_ref <- newStablePtr a
  85     let ref = castPtr (castStablePtrToPtr stable_ref)
  86     ref2 <- get_or_set ref
  87     if ref == ref2
  88       then return a
  89       else do freeStablePtr stable_ref
  90               deRefStablePtr (castPtrToStablePtr (castPtr ref2))
  91