{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
module GHC.Debug.Stub
( withGhcDebug
, withGhcDebugUnix
, withGhcDebugTCP
, SocketAddr (..)
, withGhcDebugX
, saveClosures
, Box(..)
, pause
, resume
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Word
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.StablePtr
import GHC.Exts
import GHC.Int
import GHC.IO
import GHC.Prim
import System.FilePath
import System.Directory
import System.Environment
import System.Mem
import System.IO
import GHC.Debug.Convention (socketDirectory)
foreign import ccall safe "start_over_tcp"
start_over_tcp_c :: CString -> Word16 -> IO ()
foreign import ccall safe "start_over_un"
start_over_un_c :: CString -> IO ()
foreign import ccall safe "unistd.h getpid"
getpid_c :: IO CInt
withGhcDebug :: IO a -> IO a
withGhcDebug :: forall a. IO a -> IO a
withGhcDebug IO a
main = do
String
defaultSocketPath <- IO String
getDefaultSocketPath
String
socketPath <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultSocketPath (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"GHC_DEBUG_SOCKET"
String -> IO a -> IO a
forall a. String -> IO a -> IO a
withGhcDebugUnix String
socketPath IO a
main
where
getDefaultSocketPath :: IO String
getDefaultSocketPath = do
String
socketOverride <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"GHC_DEBUG_SOCKET"
if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
socketOverride)
then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
socketOverride
else do
String
dir <- IO String
socketDirectory
String
name <- IO String
getProgName
String
pid <- CInt -> String
forall a. Show a => a -> String
show (CInt -> String) -> IO CInt -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CInt
getpid_c
let socketName :: String
socketName = String
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dir String -> String -> String
</> String
socketName)
withGhcDebugUnix :: String -> IO a -> IO a
withGhcDebugUnix :: forall a. String -> IO a -> IO a
withGhcDebugUnix String
socketPath IO a
main = do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
socketPath)
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting ghc-debug on socket: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
socketPath
ThreadId
_threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
socketPath CString -> IO ()
start_over_un_c
IO a
main
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
(String -> IO ()
removeFile String
socketPath
IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> IO ()
putStrLn (String
"ghc-debug: failed to cleanup socket: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
socketPath)
)
withGhcDebugTCP :: String -> Word16 -> IO a -> IO a
withGhcDebugTCP :: forall a. String -> Word16 -> IO a -> IO a
withGhcDebugTCP String
host Word16
port IO a
main = do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting ghc-debug on tcp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
host String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Word16 -> String
forall a. Show a => a -> String
show Word16
port)
ThreadId
_threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
host ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
host_c ->
CString -> Word16 -> IO ()
start_over_tcp_c CString
host_c Word16
port
IO a
main
data SocketAddr
= SocketAddrIp !String !Word16
| SocketAddrUnix !String
deriving (Int -> SocketAddr -> String -> String
[SocketAddr] -> String -> String
SocketAddr -> String
(Int -> SocketAddr -> String -> String)
-> (SocketAddr -> String)
-> ([SocketAddr] -> String -> String)
-> Show SocketAddr
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SocketAddr -> String -> String
showsPrec :: Int -> SocketAddr -> String -> String
$cshow :: SocketAddr -> String
show :: SocketAddr -> String
$cshowList :: [SocketAddr] -> String -> String
showList :: [SocketAddr] -> String -> String
Show, SocketAddr -> SocketAddr -> Bool
(SocketAddr -> SocketAddr -> Bool)
-> (SocketAddr -> SocketAddr -> Bool) -> Eq SocketAddr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketAddr -> SocketAddr -> Bool
== :: SocketAddr -> SocketAddr -> Bool
$c/= :: SocketAddr -> SocketAddr -> Bool
/= :: SocketAddr -> SocketAddr -> Bool
Eq)
withGhcDebugX :: SocketAddr -> IO a -> IO a
withGhcDebugX :: forall a. SocketAddr -> IO a -> IO a
withGhcDebugX (SocketAddrUnix String
socketPath) = String -> IO a -> IO a
forall a. String -> IO a -> IO a
withGhcDebugUnix String
socketPath
withGhcDebugX (SocketAddrIp String
host Word16
port) = String -> Word16 -> IO a -> IO a
forall a. String -> Word16 -> IO a -> IO a
withGhcDebugTCP String
host Word16
port
foreign import ccall safe "pause_mutator"
pause_c :: IO ()
pause :: IO ()
pause :: IO ()
pause = IO ()
performGC IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
pause_c
foreign import ccall safe "resume_mutator"
resume :: IO ()
foreign import ccall unsafe "saveClosures" c_saveClosures
:: CInt -> Ptr (Ptr ()) -> IO ()
data Box = forall a . Box a
unbox :: (forall a . a -> b) -> Box -> b
unbox :: forall b. (forall a. a -> b) -> Box -> b
unbox forall a. a -> b
f (Box a
a) = a -> b
forall a. a -> b
f a
a
saveClosures :: [Box] -> IO ()
saveClosures :: [Box] -> IO ()
saveClosures [Box]
xs = do
[Ptr ()]
sps <- (Box -> IO (Ptr ())) -> [Box] -> IO [Ptr ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Box a
x) -> StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr (StablePtr a -> Ptr ()) -> IO (StablePtr a) -> IO (Ptr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
x) [Box]
xs
[Ptr ()] -> (Ptr (Ptr ()) -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Ptr ()]
sps ((Ptr (Ptr ()) -> IO ()) -> IO ())
-> (Ptr (Ptr ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
sps_arr ->
CInt -> Ptr (Ptr ()) -> IO ()
c_saveClosures (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Box] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
xs)) Ptr (Ptr ())
sps_arr