Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: fa21b4e8 by Matthew Pickering at 2026-03-20T13:30:25+00:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 6 changed files: - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout Changes: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -71,6 +71,7 @@ import qualified GHC.Boot.TH.Monad as TH import System.Exit import System.IO import System.IO.Error +import Data.Word (Word8) -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -246,6 +247,11 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) + -- | User-defined request encoded as a tag/payload pair. This is left + -- uninterpreted by GHC and is meant for GHC API applications to be able to supply + -- their own interpreter which understands additional commands. + CustomMessage :: Word8 -> ByteString -> Message ByteString + deriving instance Show (Message a) -- | Used to dynamically create a data constructor's info table at @@ -602,6 +608,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +655,7 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a + CustomMessage tag payload -> putWord8 41 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -125,6 +125,7 @@ run m = case m of Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m + CustomMessage {} -> unexpectedMessage m unexpectedMessage :: Message a -> b unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m) ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,7 +1,11 @@ {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server - ( serv + ( MessageHook + , CustomMessageHandler + , serv + , servWithCustom , defaultServer + , defaultServerWithCustom ) where @@ -10,8 +14,8 @@ import GHCi.Run import GHCi.Signals import GHCi.TH import GHCi.Message -#if defined(wasm32_HOST_ARCH) import Data.ByteString (ByteString) +#if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -22,6 +26,7 @@ import GHC.Wasm.Prim #else import GHCi.Utils #endif +import Data.Word (Word8) import Control.DeepSeq import Control.Exception @@ -36,11 +41,27 @@ import System.IO type MessageHook = Msg -> IO Msg +-- | How to interpret the 'CustomCommand'. +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString) + +noCustomHandler :: CustomMessageHandler +noCustomHandler _ _ = return Nothing + trace :: String -> IO () trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe restore = loop +serv verbose hook pipe restore = + servWithCustom verbose hook pipe restore noCustomHandler + +servWithCustom + :: Bool + -> MessageHook + -> Pipe + -> (forall a .IO a -> IO a) + -> CustomMessageHandler + -> IO () +servWithCustom verbose hook pipe restore customHandler = loop where loop = do when verbose $ trace "reading pipe..." @@ -50,6 +71,7 @@ serv verbose hook pipe restore = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs @@ -61,6 +83,13 @@ serv verbose hook pipe restore = loop writePipe pipe (put r) loop + handleCustom tag payload = do + mresp <- customHandler tag payload + case mresp of + Just resp -> reply resp + Nothing -> + error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + -- Run some TH code, which may interact with GHC by sending -- THMessage requests, and then finally send RunTHDone followed by a -- QResult. For an overview of how TH works with Remote GHCi, see @@ -109,12 +138,24 @@ serv verbose hook pipe restore = loop -- | Default server #if defined(wasm32_HOST_ARCH) defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO () -defaultServer cb_sig cb_recv cb_send = do +defaultServer cb_sig cb_recv cb_send = + defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler + +defaultServerWithCustom + :: Callback (JSVal -> IO ()) + -> Callback (IO JSUint8Array) + -> Callback (JSUint8Array -> IO ()) + -> CustomMessageHandler + -> IO () +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do args <- getArgs let rest = args #else defaultServer :: IO () -defaultServer = do +defaultServer = defaultServerWithCustom noCustomHandler + +defaultServerWithCustom :: CustomMessageHandler -> IO () +defaultServerWithCustom customHandler = do args <- getArgs (outh, inh, rest) <- case args of @@ -152,7 +193,7 @@ defaultServer = do putStrLn "Waiting 3s" threadDelay 3000000 - uninterruptibleMask $ serv verbose hook pipe + uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-} +module Main (main) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Word (Word8) +import GHCi.Message + ( Message(..) + , mkPipeFromHandles + , remoteCall + , Pipe + ) +import GHCi.Server + ( CustomMessageHandler + , defaultServerWithCustom + ) +import System.Environment + ( getArgs + , getExecutablePath + , getProgName + , withArgs + ) +import System.Exit (exitFailure) +import System.IO + ( Handle + , BufferMode(..) + , hSetBuffering + , hSetBinaryMode + , hClose + , hPutStrLn + , stderr + ) +import System.Posix.IO + ( createPipe + , fdToHandle + , setFdOption + , FdOption(CloseOnExec) + ) +import System.Process + ( createProcess + , proc + , std_in + , std_out + , std_err + , StdStream(Inherit) + , terminateProcess + , waitForProcess + , ProcessHandle + ) +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +-- Shared request/response definitions and helpers + +data ClientCommand a where + SquareCommand :: Int -> ClientCommand Int + MulCommand :: Int -> Int -> ClientCommand Int + +deriving instance (Show (ClientCommand a)) + +data Some c f where + Some :: c a => f a -> Some c f + + +instance Bin.Binary (Some Bin.Binary ClientCommand) where + put (Some i) = + case i of + SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n + MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n + + get = do + (tag :: Word8) <- Bin.get + fmap Some $ case tag of + 0 -> SquareCommand <$> Bin.get + 1 -> MulCommand <$> Bin.get <*> Bin.get + + +customTag :: Word8 +customTag = 0x42 + +encodeLazy :: Bin.Binary a => a -> BS.ByteString +encodeLazy = BL.toStrict . Bin.encode + +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a +decodeLazy bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +-------------------------------------------------------------------------------- +-- Mode selection + +data Mode + = RunClient Int + | RunServer [String] -- forwarded to GHCi.Server + +defaultInput :: Int +defaultInput = 12 + +parseMode :: [String] -> Either String Mode +parseMode [] = Right (RunClient defaultInput) +parseMode ["client"] = Right (RunClient defaultInput) +parseMode ["client", nStr] = + case readMaybe nStr of + Just n -> Right (RunClient n) + Nothing -> Left $ "Unable to parse integer argument: " ++ nStr +parseMode ("client":_) = Left "Too many arguments for client mode." +parseMode ("server":rest) = Right (RunServer rest) +parseMode args = Left "Unknown mode, use client/server" + +usage :: IO () +usage = do + prog <- getProgName + putStrLn $ unlines + [ "Usage:" + , " " ++ prog ++ " [client [n]] Run the client and square n (default 12)." + , " " ++ prog ++ " server <write-fd> <read-fd> Run as an iserv process." + ] + +-------------------------------------------------------------------------------- +-- Client/server drivers + +main :: IO () +main = do + args <- getArgs + case parseMode args of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right (RunClient n) -> runClient n + Right (RunServer serverArgs) -> + withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand)) + +handleClientCommand :: ClientCommand a -> IO a +handleClientCommand (SquareCommand n) = pure $ n * n +handleClientCommand (MulCommand n m) = pure $ n * m + + +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a +customMessage pipe c = do + let payload = encodeLazy (Some @Bin.Binary c) + putStrLn $ "Sending: " ++ show c + respBytes <- remoteCall pipe (CustomMessage customTag payload) + case decodeLazy respBytes of + Left err -> error $ "Decode error: " ++ err + Right res -> pure res + + +runClient :: Int -> IO () +runClient input = do + serverExe <- getExecutablePath + withServer serverExe $ \hFromServer hToServer -> do + pipe <- mkPipeFromHandles hFromServer hToServer + res <- customMessage pipe (SquareCommand input) + putStrLn $ "Square returned: " ++ show res + res2 <- customMessage pipe (MulCommand 2 res) + putStrLn $ "Mul returned: " ++ show res2 + +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a +withServer serverExe action = do + (ghcRead, serverWrite) <- createPipe + (serverRead, ghcWrite) <- createPipe + mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead] + let args = ["server", show serverWrite, show serverRead] + (_, _, _, ph) <- createProcess (proc serverExe args) + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + bracket (mkHandles ghcRead ghcWrite) + (\(hFromServer, hToServer) -> do + hClose hFromServer + hClose hToServer + terminateProcess ph + void (waitForProcess ph)) + (\(hFromServer, hToServer) -> action hFromServer hToServer) + where + mkHandles r w = do + hR <- fdToHandle r + hW <- fdToHandle w + mapM_ (`hSetBuffering` NoBuffering) [hR, hW] + mapM_ (`hSetBinaryMode` True) [hR, hW] + pure (hR, hW) + +-------------------------------------------------------------------------------- +-- Custom handler + +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler +customHandler handler tag payload + | tag == customTag = + case decodeLazy payload of + Left err -> do + hPutStrLn stderr $ "Custom handler decode error: " ++ err + pure Nothing + Right (Some @Bin.Binary r) -> do + res <- handler r + pure . Just $ encodeLazy res + | otherwise = pure Nothing ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -0,0 +1,11 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , js_skip + , wasm_skip + , req_process + , req_interp + , omit_ways(prof_ways) + ], + multimod_compile_and_run, + ['Main.hs', '-package ghci']) ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout ===================================== @@ -0,0 +1,4 @@ +Sending: SquareCommand 12 +Square returned: 144 +Sending: MulCommand 2 144 +Mul returned: 288 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21b4e88863803640451ec7f534ea37... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21b4e88863803640451ec7f534ea37... You're receiving this email because of your account on gitlab.haskell.org.