{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-|
This module provides the functions you need to use to instrument your application
so it can be debugged using ghc-debug. Usually all you need to do is to
wrap the main function with the 'withGhcDebug' wrapper.

@
    main = withGhcDebug $ do ...
@

Then when you application starts, a socket will be created which the debugger
can be attached to. The location of the socket is controlled by the @GHC_DEBUG_SOCKET@
environment variable.
-}
module GHC.Debug.Stub (withGhcDebug, saveClosures, Box(..), pause, resume) where

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Maybe (fromMaybe)
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"
    start_c :: CString -> IO ()

foreign import ccall safe "unistd.h getpid"
    getpid_c :: IO CInt

-- | Start listening for remote debugging. You should wrap your main thread
-- in this as it performs some cleanup on exit. If not used on the Main thread,
-- user interupt (Ctrl-C) may skip the cleanup step.
--
-- By default the socket is created by referring to 'socketDirectory' which is
-- in your XDG data directory.
--
-- The socket created can also be controlled using the @GHC_DEBUG_SOCKET@
-- environment variable.
withGhcDebug :: IO a -> IO a
withGhcDebug :: forall a. IO a -> IO a
withGhcDebug IO a
main = do
    -- Pick a socket file path.
    String
socketPath <- 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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
socketOverride)
        then String -> IO String
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 (m :: * -> *) a. Monad m => a -> m a
return (String
dir String -> String -> String
</> String
socketName)

    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

    -- Start a thread to handle requests
    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_c

    -- Run the main thread with cleanup
    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 (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)
        )

-- | Break program execution for debugging.
foreign import ccall safe "pause_mutator"
    pause_c :: IO ()

pause :: IO ()
pause :: IO ()
pause = IO ()
performGC IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
pause_c

-- | Resume program execution for debugging.
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

-- | Mark a set of closures to be saved, they can then be retrieved from
-- the debugger using the 'RequestSavedClosures' requests. This can be
-- useful to transmit specific closures you care about (such as a cache or
-- large map).
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)
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
xs)) Ptr (Ptr ())
sps_arr