ghc-debug-stub 0.4.0.0 → 0.5.0.0

raw patch · 4 files changed

+116/−14 lines, 4 filesdep ~ghc-debug-conventiondep ~ghc-primPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-debug-convention, ghc-prim

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• cbits/stub.cpp +52/−2
• ghc-debug-stub.cabal +3/−3
• src/GHC/Debug/Stub.hs +57/−9

@@ -1,5 +1,9 @@ # Revision history for ghc-debug-stub +## 0.5.0.0 -- 2023-06-06++* Add support for debugging over a TCP socket (`withGhcDebugTCP`)+ ## 0.4.0.0 -- 2022-12-14  * Fix compatability with HEAD/9.4/9.2

@@ -778,7 +778,57 @@ */  extern "C"-void start(const char* socket_path) {+void start_over_tcp(const char* socket_addr, uint16_t port) {+    trace("starting with socket: %s:%d\n", socket_addr, port);+    struct sockaddr_in local, remote;+    int family;++    // try ipv4+    if (inet_pton(AF_INET, socket_addr, &local.sin_addr) == 1) {+        family = AF_INET;+    } else {+        // try ipv6+        if (inet_pton(AF_INET6, socket_addr, &local.sin_addr) == 1) {+            family = AF_INET6;+        } else {+            barf("invalid socket address: \"%s\"", socket_addr);+        }+    }++    // Open the socket for listening+    int listenHdl = socket(family, SOCK_STREAM, 0);+    if (listenHdl == -1) {+        barf("socket failed");+    }++    // Bind the socket to an address+    local.sin_family = family;+    local.sin_port = htons(port);+    if (bind(listenHdl, (struct sockaddr *) &local, sizeof(local)) != 0) {+        barf("bind failed");+    }++    // Listen for connections+    if (listen(listenHdl, 1) != 0) {+        barf("listen failed");+    }+    fflush(stdout);++    while (true) {+        // Wait for client connection+        socklen_t len = sizeof(remote);+        int commHdl = accept(listenHdl, (struct sockaddr *) &remote, &len);+        if (commHdl == -1) {+            barf("accept failed %s", strerror(errno));+        }++        // Handle and on disconnect listen for more connections+        handle_connection(commHdl);+    }+}++extern "C"+void start_over_un(const char* socket_path) {     trace("starting with socket path: %s\n", socket_path);     struct sockaddr_un local, remote; @@ -813,7 +863,7 @@         if (commHdl == -1) {             barf("accept failed %s", strerror(errno));         }-        +         // Handle and on disconnect listen for more connections         handle_connection(commHdl);     }

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                ghc-debug-stub-version:             0.4.0.0+version:             0.5.0.0 synopsis:            Functions for instrumenting your application so the heap                      can be analysed with ghc-debug-common. description:         Functions for instrumenting your application so the heap can@@ -26,8 +26,8 @@   build-depends:       base >=4.16 && < 5                      , directory ^>= 1.3                      , filepath ^>= 1.4-                     , ghc-prim ^>= 0.8-                     , ghc-debug-convention == 0.4.0.0+                     , ghc-prim >= 0.8 && < 0.11+                     , ghc-debug-convention == 0.5.0.0   default-language:    Haskell2010   cxx-sources:         cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp   cxx-options:         -std=gnu++11 -pthread -O3 -g3 -DTHREADED_RTS

@@ -14,12 +14,23 @@ 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+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@@ -36,15 +47,19 @@  import GHC.Debug.Convention (socketDirectory) -foreign import ccall safe "start"-    start_c :: CString -> IO ()+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 --- | 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.+-- | Start listening on a unix domain 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.@@ -53,8 +68,11 @@ -- environment variable. withGhcDebug :: IO a -> IO a withGhcDebug main = do-    -- Pick a socket file path.-    socketPath <- do+    defaultSocketPath <- getDefaultSocketPath+    socketPath <- fromMaybe defaultSocketPath <$> lookupEnv "GHC_DEBUG_SOCKET"+    withGhcDebugUnix socketPath main+  where+    getDefaultSocketPath = do         socketOverride <- fromMaybe "" <$> lookupEnv "GHC_DEBUG_SOCKET"         if not (null socketOverride)         then return socketOverride@@ -65,11 +83,18 @@             let socketName = pid ++ "-" ++ name             return (dir </> socketName) +-- | Similar to 'withGhcDebug', but with an explicit socket path+--+-- The file directory will be created automatically if it does not exist.+--+-- > main = withGhcDebugUnix "/tmp/ghc-debug" $ do ...+withGhcDebugUnix :: String -> IO a -> IO a+withGhcDebugUnix socketPath main = do     createDirectoryIfMissing True (takeDirectory socketPath)     hPutStrLn stderr $ "Starting ghc-debug on socket: " ++ socketPath      -- Start a thread to handle requests-    _threadId <- forkIO $ withCString socketPath start_c+    _threadId <- forkIO $ withCString socketPath start_over_un_c      -- Run the main thread with cleanup     main@@ -77,6 +102,29 @@         (removeFile socketPath             <|> putStrLn ("ghc-debug: failed to cleanup socket: " ++ socketPath)         )++-- | Start listening on a tcp for remote debugging.+--+-- > main = withGhcDebugTCP "127.0.0.1" 1235 $ do ...+withGhcDebugTCP :: String -> Word16 -> IO a -> IO a+withGhcDebugTCP host port main = do+    hPutStrLn stderr $ "Starting ghc-debug on tcp: " ++ host ++ ":" ++ (show port)++    -- Start a thread to handle requests+    _threadId <- forkIO $ withCString host $ \host_c ->+      start_over_tcp_c host_c port++    -- Run the main thread+    main++data SocketAddr+  = SocketAddrIp !String !Word16+  | SocketAddrUnix !String+  deriving (Show, Eq)++withGhcDebugX :: SocketAddr -> IO a -> IO a+withGhcDebugX (SocketAddrUnix socketPath) = withGhcDebugUnix socketPath+withGhcDebugX (SocketAddrIp host port) = withGhcDebugTCP host port  -- | Break program execution for debugging. foreign import ccall safe "pause_mutator"