March 2026 - ghc-commits

[Git][ghc/ghc] Deleted branch wip/T17202
by Magnus (＠MangoIV) 20 Mar '26

20 Mar '26

Magnus deleted branch wip/T17202 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Add support for custom external interpreter commands
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: 12fbd7bd by Matthew Pickering at 2026-03-20T14:06:28+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,10 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , when(config.cross, 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/12fbd7bde6365a8f2d4f750f3b23090… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12fbd7bde6365a8f2d4f750f3b23090… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Apply 1 suggestion(s) to 1 file(s)
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: ee594de9 by Rodrigo Mesquita at 2026-03-20T14:05:30+00:00 Apply 1 suggestion(s) to 1 file(s) Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 1 changed file: - testsuite/tests/ghci/custom-external-interpreter-commands/all.T Changes: ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -1,8 +1,7 @@ test('custom-external-interpreter-commands', [ extra_files(['Main.hs']) , windows_skip - , js_skip - , wasm_skip + , when(config.cross, skip) , req_process , req_interp , omit_ways(prof_ways) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee594de90f159204bffb0f58bad79d4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee594de90f159204bffb0f58bad79d4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Fix CStub printing
by Hannes Siebenhandl (＠fendor) 20 Mar '26

20 Mar '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 661b24c6 by fendor at 2026-03-20T14:38:34+01:00 Fix CStub printing - - - - - 1 changed file: - compiler/GHC/Driver/CodeOutput.hs Changes: ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -346,15 +346,15 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs pprCStubInitFiniDecls :: Platform -> CStub -> SDoc pprCStubInitFiniDecls platform cstub = - vcat (zipWith (pprInitOrFiniDecl ".init_array") [0 :: Int ..] (getInitializers cstub)) - $$ vcat (zipWith (pprInitOrFiniDecl ".fini_array") [0 :: Int ..] (getFinalizers cstub)) + vcat (zipWith (pprInitOrFiniDecl "ini" ".init_array") [0 :: Int ..] (getInitializers cstub)) + $$ vcat (zipWith (pprInitOrFiniDecl "fini" ".fini_array") [0 :: Int ..] (getFinalizers cstub)) where - pprInitOrFiniDecl :: String -> Int -> CLabel -> SDoc - pprInitOrFiniDecl section_name n lbl = + pprInitOrFiniDecl :: String -> String -> Int -> CLabel -> SDoc + pprInitOrFiniDecl suf section_name n lbl = vcat [ hsep [text "extern void", pprCLabel platform lbl, text "(void);"] , hsep [ text "static void (*" - <> text "__ghc_init_fini_" + <> text "__ghc_" <> text suf <> text "_" <> int n <> text ")(void)" , text "__attribute__((used, section(" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/661b24c658a9b86139b1758cb5bfc6b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/661b24c658a9b86139b1758cb5bfc6b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Add support for custom external interpreter commands
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

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/fa21b4e88863803640451ec7f534ea3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21b4e88863803640451ec7f534ea3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] 2 commits: Wibbles
by Simon Peyton Jones (＠simonpj) 20 Mar '26

20 Mar '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 6f8e976b by Simon Peyton Jones at 2026-03-20T11:00:39+00:00 Wibbles - - - - - 742099ce by Simon Peyton Jones at 2026-03-20T12:46:27+00:00 More improvements ..with help form Matthew, to module graph dependencies - - - - - 22 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Unit/Module/ModSummary.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-prim/ghc-prim.cabal - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/parser/should_fail/T16270h.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1637,8 +1637,8 @@ integralClassKey = mkPreludeClassUnique 7 monadClassKey = mkPreludeClassUnique 8 dataClassKey = mkPreludeClassUnique 9 functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 +numClassKey = mkPreludeClassUnique 11 -- 2b +ordClassKey = mkPreludeClassUnique 12 -- 2c readClassKey = mkPreludeClassUnique 13 realClassKey = mkPreludeClassUnique 14 realFloatClassKey = mkPreludeClassUnique 15 ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -879,7 +879,7 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) - -- Also copied from 'getImports' + -- Also copied from 'getImportEdges' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps implicit_prelude = xopt LangExt.ImplicitPrelude dflags ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -1536,10 +1536,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name) <- ExceptT $ do - let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags - popts = initParserOpts pi_local_dflags - sec = initSourceErrorContext pi_local_dflags - mimps <- getImports popts sec imp_prelude pi_hspp_buf pi_hspp_fn src_fn + mimps <- getImportEdges pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -672,12 +672,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do (hspp_buf,mod_name,imps,src_imps) <- do buf <- hGetStringBuffer input_fn -- TODO: handle implicit knownkey names here? - let imp_prelude = xopt LangExt.ImplicitPrelude dflags - popts = initParserOpts dflags - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn)) sec = initSourceErrorContext dflags - eimps <- getImports popts sec imp_prelude buf input_fn (basename <.> suff) + eimps <- getImportEdges dflags buf input_fn (basename <.> suff) case eimps of Left errs -> throwErrors sec (GhcPsMessage <$> errs) Right (src_imps,imps, L _ mod_name) -> return ===================================== compiler/GHC/Parser/Header.hs ===================================== @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module GHC.Parser.Header - ( getImports + ( getImportEdges , mkPrelImports -- used by the renamer too , getOptionsFromFile , getOptions @@ -24,7 +24,8 @@ import GHC.Prelude import GHC.Data.Bag -import GHC.Driver.DynFlags (DynFlags) +import GHC.Driver.DynFlags +import GHC.Driver.Config.Parser( initParserOpts ) import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! import GHC.Parser.Errors.Types @@ -47,6 +48,8 @@ import GHC.Utils.Monad import GHC.Utils.Error import GHC.Utils.Exception as Exception +import qualified GHC.LanguageExtensions as LangExt + import GHC.Data.StringBuffer import GHC.Data.Maybe import GHC.Data.FastString @@ -63,26 +66,31 @@ import Text.Read (readPrec) ------------------------------------------------------------------------------ --- | Parse the imports of a source file. +-- | Returns the dependency edges of the module graph, by +-- * parsing the module and looking for `import` declarations +-- * adding edges for Prelude and GHC.KnownKeyNames as required -- -- Throws a 'SourceError' if parsing fails. -getImports :: ParserOpts -- ^ Parser options - -> SourceErrorContext - -> Bool -- ^ Implicit Prelude? - -> StringBuffer -- ^ Parse this. - -> FilePath -- ^ Filename the buffer came from. Used for - -- reporting parse error locations. - -> FilePath -- ^ The original source filename (used for locations - -- in the function result) - -> IO (Either - (Messages PsMessage) - ([Located ModuleName], - [(ImportLevel, RawPkgQual, Located ModuleName)], - Located ModuleName)) - -- ^ The source imports and normal imports (with optional package - -- names from -XPackageImports), and the module name. -getImports popts sec implicit_prelude buf filename source_filename = do +getImportEdges + :: DynFlags + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> IO (Either + (Messages PsMessage) + ([Located ModuleName], -- {-# SOURCE #-} imports + [(ImportLevel, RawPkgQual, Located ModuleName)], -- Normal imports + Located ModuleName)) -- Name of current module + -- ^ The source imports and normal imports (with optional package + -- names from -XPackageImports), and the module name. +getImportEdges dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 + imp_prelude = xopt LangExt.ImplicitPrelude dflags + rebindable_kn = gopt Opt_RebindableKnownKeyNames dflags + popts = initParserOpts dflags + sec = initSourceErrorContext dflags case unP parseHeader (initParserState popts buf loc) of PFailed pst -> -- assuming we're not logging warnings here as per below @@ -102,16 +110,19 @@ getImports popts sec implicit_prelude buf filename source_filename = do mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps - generated_imports = mkPrelImports (unLoc mod) implicit_prelude imps - convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) + generated_imports = mkPrelImports (unLoc mod) imp_prelude imps + convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i) + + known_key_name_edges -- Add an edge to GHC.KnownKeyNames, unless -frebindable-known-key-names is on + | rebindable_kn = [] + | otherwise = [(NormalLevel, NoRawPkgQual, noLoc kNOWN_KEY_NAMES)] in - return (map convImport_src src_idecls - , map convImport (generated_imports ++ ord_idecls) + return ( map convImport_src src_idecls + , known_key_name_edges ++ + map convImport (generated_imports ++ ord_idecls) , reLoc mod) - - mkPrelImports :: ModuleName -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs] @@ -261,7 +272,7 @@ getOptions opts sec supported buf filename -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through --- CPP, so we can't use the same trick as 'getImports'. +-- CPP, so we can't use the same trick as 'getImportEdges'. getOptions' :: ParserOpts -> SourceErrorContext -> [String] ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -2203,7 +2203,8 @@ warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () warnUnusedImport rdr_env (L loc decl, used, unused, unused_wcs) -- Do not warn for 'import M()' - | Just (Exactly, L _ []) <- ideclImportList decl + | Just (Exactly, _) <- ideclImportList decl + , null unused = return () -- Note [Do not warn about Prelude hiding] ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -1083,11 +1083,14 @@ tcGetDefaultTys ; checkWiredInTyCon doubleTyCon ; numDef <- case lookupDefaultEnv_Directly user_defaults numClassKey of Nothing -> do { integer_ty <- tcMetaTy integerTyConName - ; numClass <- tcLookupKnownKeyClass numClassKey - ; pure $ unitDefaultEnv $ builtinDefaults numClass [integer_ty, doubleTy] - } - -- The Num class is already user-defaulted, no need to construct the builtin default - _ -> pure emptyDefaultEnv + ; numClass <- tcLookupKnownKeyClass numClassKey + ; pure $ unitDefaultEnv $ + builtinDefaults numClass [integer_ty, doubleTy] } + + _ -> -- The Num class is already user-defaulted, so + -- no need to construct the builtin default + pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults -- override them. We put the user-supplied ones last because in `mconcat` -- on `DefaultEnv` the rightmost wins. ===================================== compiler/GHC/Unit/Module/ModSummary.hs ===================================== @@ -86,6 +86,7 @@ data ModSummary -- ^ Source imports of the module ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* + -- Includes 'import Prelude' if -XImplicitPrelude ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. ===================================== libraries/base/src/Control/Applicative.hs ===================================== @@ -69,6 +69,7 @@ import GHC.Internal.Base ( import GHC.Internal.Functor.ZipList (ZipList(..)) import GHC.Internal.Types import GHC.Generics +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- $setup -- >>> import Prelude ===================================== libraries/base/src/Data/Bool.hs ===================================== @@ -24,7 +24,8 @@ module Data.Bool bool ) where -import Prelude (Bool(..), (&&), (||), not, otherwise) +import Prelude ( Bool(..), (&&), (||), not, otherwise ) +import Prelude( Num ) -- For -frebindable-known-key-names (defaulting) -- $setup -- >>> import Prelude ===================================== libraries/base/src/Data/Enum.hs ===================================== @@ -25,7 +25,7 @@ module Data.Enum ) where import GHC.Internal.Enum -import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- | Returns a list of all values of an enum type -- ===================================== libraries/base/src/Data/List.hs ===================================== @@ -193,6 +193,7 @@ import GHC.Internal.Int (Int) import GHC.Internal.Num ((-)) import GHC.List (build) import qualified Data.List.NubOrdSet as NubOrdSet +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) inits1, tails1 :: [a] -> [NonEmpty a] ===================================== libraries/base/src/Data/List/NubOrdSet.hs ===================================== @@ -14,6 +14,7 @@ module Data.List.NubOrdSet ( import Data.Bool (Bool(..)) import GHC.Internal.Data.Function ((.)) import GHC.Internal.Data.Ord (Ordering(..)) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- | Implemented as a red-black tree, a la Okasaki. data NubOrdSet a ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -7,12 +7,11 @@ -- Stability : internal -- Portability : non-portable (GHC Extensions) -- --- TODO: Note on KnownKeyNames by export --- module GHC.KnownKeyNames ( Rational - , Eq, Ord, Show, Num, Bounded + , Eq, Ord, Show, Num + , Enum, Bounded , Foldable, Traversable , IsString , Functor, Monad ===================================== libraries/base/src/GHC/RTS/Flags.hs ===================================== @@ -62,6 +62,7 @@ import qualified GHC.Internal.RTS.Flags as Internal import GHC.Internal.IO.SubSystem (IoSubSystem(..)) import Data.Word (Word32,Word64,Word) +import Prelude( Num ) -- For -frebindable-known-key-names (used when defaulting) -- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- ===================================== libraries/base/src/GHC/Stats.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Stats import Prelude (Bool,IO,Read,Show,(<$>)) +import Prelude (Num) -- For -frebindable-known-key-names (defaulting) import qualified GHC.Internal.Stats as Internal import GHC.Generics (Generic) ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -34,6 +34,7 @@ import Data.Maybe (Maybe (Nothing)) import Data.String (String) import Data.Eq ((/=)) import System.IO (IO, hPutStrLn, stderr) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- --------------------------------------------------------------------------- -- exitWith ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -61,6 +61,7 @@ import GHC.IO.Exception ) import Foreign.Ptr (Ptr) import Foreign.C.Types (CInt) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- * Obtaining POSIX file descriptors and Windows handles ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String.hs ===================================== @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines IsString + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Data.String ===================================== libraries/ghc-prim/ghc-prim.cabal ===================================== @@ -26,6 +26,10 @@ Library build-depends: ghc-internal + ghc-options: -frebindable-known-key-names + -- Do not create dependencies on GHC.KnownKeyNames! + -- It doesn't exist yet. + other-modules: -- dummy module to make Hadrian/GHC build a valid library... Dummy ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -61,7 +61,7 @@ main = do , "import B" ] , [ "module B !parse_error where" - -- ^ this used to cause getImports to throw an exception instead + -- ^ this used to cause getImportEdges to throw an exception instead -- of having downsweep return an error for just this module , "import C" ] @@ -95,7 +95,7 @@ main = do ] , [ "module B where" , "!parse_error" - -- ^ this is silently ignored, getImports assumes the import + -- ^ this is silently ignored, getImportEdges assumes the import -- list is just empty. This smells like a parser bug to me but -- I'm still documenting this behaviour here. , "import C" ===================================== testsuite/tests/parser/should_fail/T16270h.hs ===================================== @@ -1,5 +1,5 @@ -- We can't test module header parsing errors using the same file as other --- parsing errors (in ../T16270.hs) because HeaderInfo.getImports fails fast +-- parsing errors (in ../T16270.hs) because HeaderInfo.getImportEdges fails fast -- on parsing imports: -- -- if errorsFound dflags ms View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e86bd93aadad57b40a75663eb474b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e86bd93aadad57b40a75663eb474b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/dcoutts/remove-signal-tickers
by Duncan Coutts (＠dcoutts) 20 Mar '26

20 Mar '26

Duncan Coutts pushed new branch wip/dcoutts/remove-signal-tickers at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/remove-signal-tickers You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/VeryMilkyJoe/no-mod-loc-pat] Remove backwards compatibility pattern synonym `ModLocation`
by Jana Chadt (＠VeryMilkyJoe) 20 Mar '26

20 Mar '26

Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC Commits: 3e1b048b by VeryMilkyJoe at 2026-03-19T14:34:28+01:00 Remove backwards compatibility pattern synonym `ModLocation` Fixes #24932 - - - - - 5 changed files: - compiler/GHC.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Unit/Module/Location.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -79,7 +79,13 @@ module GHC ( ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgLookupModule, ModSummary(..), ms_mod_name, ModLocation(..), - pattern ModLocation, + ml_hs_file, + ml_hi_file, + ml_dyn_hi_file, + ml_obj_file, + ml_dyn_obj_file, + ml_hie_file, + ml_bytecode_file, getModSummary, getModuleGraph, isLoaded, @@ -1575,7 +1581,7 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions -getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags) +getModuleSourceAndFlags :: ModSummary -> IO (FilePath, StringBuffer, DynFlags) getModuleSourceAndFlags m = do case ml_hs_file $ ms_location m of Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m)) ===================================== compiler/GHC/CoreToStg/AddImplicitBinds.hs ===================================== @@ -10,7 +10,7 @@ import GHC.Prelude import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) ) -import GHC.Unit( ModLocation(..) ) +import GHC.Unit( ModLocation(..), ml_hs_file ) import GHC.Core import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId ) ===================================== compiler/GHC/Unit/Module/Location.hs ===================================== @@ -2,22 +2,19 @@ {-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location - ( ModLocation - ( .. - , ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - ) - , pattern ModLocation + ( ModLocation(..) , addBootSuffix , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix , mkFileSrcSpan + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + , ml_bytecode_file ) where @@ -128,33 +125,30 @@ mkFileSrcSpan mod_loc -- Helpers for backwards compatibility -- ---------------------------------------------------------------------------- -{-# COMPLETE ModLocation #-} - -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation -pattern ModLocation - { ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - } <- OsPathModLocation - { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) - , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) - , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) - , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) - , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) - , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) - , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file) - } where - ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file - = OsPathModLocation - { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file - , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file - , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file - , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file - , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file - , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file - , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file - } +ml_hs_file :: ModLocation -> Maybe FilePath +{-# INLINE ml_hs_file #-} +ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath + +ml_hi_file :: ModLocation -> FilePath +{-# INLINE ml_hi_file #-} +ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath + +ml_dyn_hi_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_hi_file #-} +ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath + +ml_obj_file :: ModLocation -> FilePath +{-# INLINE ml_obj_file #-} +ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath + +ml_dyn_obj_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_obj_file #-} +ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath + +ml_hie_file :: ModLocation -> FilePath +{-# INLINE ml_hie_file #-} +ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath + +ml_bytecode_file :: ModLocation -> FilePath +{-# INLINE ml_bytecode_file #-} +ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) = -- with the module summary information let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Load a module graph and report the result ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Test a module graph and report if it matches expected invariant violations testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e1b048b78b54a5a87be5a967d2d135… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e1b048b78b54a5a87be5a967d2d135… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] Wibbles
by Simon Peyton Jones (＠simonpj) 20 Mar '26

20 Mar '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 0e86bd93 by Simon Peyton Jones at 2026-03-20T09:42:03+00:00 Wibbles - - - - - 3 changed files: - compiler/GHC/Tc/Utils/Env.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/System/IO/Unsafe.hs Changes: ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -505,7 +505,7 @@ to bring the data constructor A into scope. We thus emit the following message: ************************************************************************ -} -tcLookupKnownKeyGlobal :: Unique -> TcM TyThing +tcLookupKnownKeyGlobal :: HasDebugCallStack => Unique -> TcM TyThing tcLookupKnownKeyGlobal uniq = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames ; mb_rdr_env <- if rebindable_path @@ -517,7 +517,7 @@ tcLookupKnownKeyGlobal uniq Succeeded thing -> return thing Failed msg -> failWithTc (TcRnInterfaceError msg) } -tcLookupKnownKeyClass :: Unique -> TcM Class +tcLookupKnownKeyClass :: HasDebugCallStack => Unique -> TcM Class tcLookupKnownKeyClass uniq = do { thing <- tcLookupKnownKeyGlobal uniq ; case thing of @@ -525,7 +525,7 @@ tcLookupKnownKeyClass uniq -> return cls _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } -tcLookupKnownKeyTyCon :: Unique -> TcM TyCon +tcLookupKnownKeyTyCon :: HasDebugCallStack => Unique -> TcM TyCon tcLookupKnownKeyTyCon uniq = do { thing <- tcLookupKnownKeyGlobal uniq ; case thing of ===================================== libraries/base/src/Data/Enum.hs ===================================== @@ -25,6 +25,7 @@ module Data.Enum ) where import GHC.Internal.Enum +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names -- | Returns a list of all values of an enum type -- @@ -51,4 +52,4 @@ import GHC.Internal.Enum -- -- @since base-4.22.0.0 enumerate :: (Enum a, Bounded a) => [a] -enumerate = [minBound .. maxBound] \ No newline at end of file +enumerate = [minBound .. maxBound] ===================================== libraries/base/src/System/IO/Unsafe.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.IO import GHC.Internal.IORef import GHC.Internal.Exception import GHC.Internal.Control.Exception +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names -- | A slightly faster version of `GHC.Internal.System.IO.fixIO` that may not be -- safe to use with multiple threads. The unsafety arises when used View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e86bd93aadad57b40a75663eb474b5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e86bd93aadad57b40a75663eb474b5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] Fix import
by Simon Peyton Jones (＠simonpj) 20 Mar '26

20 Mar '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 2174e05a by Simon Peyton Jones at 2026-03-20T09:27:33+00:00 Fix import - - - - - 1 changed file: - compiler/GHC/Tc/Errors/Hole.hs Changes: ===================================== compiler/GHC/Tc/Errors/Hole.hs ===================================== @@ -86,7 +86,7 @@ import GHC.Hs.Doc import GHC.Unit.Module.ModIface ( mi_docs ) import GHC.Iface.Load ( loadInterfaceForName ) -import GHC.Builtin.Utils (knownKeyNames) +import GHC.Builtin.Utils (wiredInNames) import GHC.Tc.Errors.Hole.FitTypes import GHC.Tc.Errors.Hole.Plugin View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2174e05ae3490c490986d5caefd74c5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2174e05ae3490c490986d5caefd74c5… You're receiving this email because of your account on gitlab.haskell.org.

1 0