- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/dep-json-link-nodes] WIP: Add support for link nodes
by Hannes Siebenhandl (＠fendor) 15 Oct '26

15 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/dep-json-link-nodes at Glasgow Haskell Compiler / GHC Commits: 411a9167 by fendor at 2026-10-15T13:48:50+02:00 WIP: Add support for link nodes - - - - - 19 changed files: - compiler/GHC/Driver/MakeFile.hs - testsuite/tests/driver/mkdepend/all.T - + testsuite/tests/driver/mkdepend/mhu04/app/Main.hs - + testsuite/tests/driver/mkdepend/mhu04/app/Utils.hs - + testsuite/tests/driver/mkdepend/mhu04/lib/Lib.hs - + testsuite/tests/driver/mkdepend/mhu04/lib/Lib/Internal.hs - + testsuite/tests/driver/mkdepend/mhu04/unitApp - + testsuite/tests/driver/mkdepend/mhu04/unitLib - + testsuite/tests/driver/mkdepend/mhu05/app/Main.hs - + testsuite/tests/driver/mkdepend/mhu05/lib/Lib.hs - + testsuite/tests/driver/mkdepend/mhu05/lib/Lib/Internal.hs - + testsuite/tests/driver/mkdepend/mhu05/test/Spec.hs - + testsuite/tests/driver/mkdepend/mhu05/unitApp - + testsuite/tests/driver/mkdepend/mhu05/unitLib - + testsuite/tests/driver/mkdepend/mhu05/unitTest - + testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-makefile - + testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-makefile Changes: ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -216,6 +216,18 @@ data Dep { dep_path :: OsPath } +data DepLink + = DepLink + { link_output :: !UnitId + , link_nodes :: ![DepLinkNode] + } + +data DepLinkNode + = DepLink_Unit !UnitId + | DepLink_Module !ModuleNameWithIsBoot !UnitId + | DepLink_HomeUnit {-# UNPACK #-} !UnitId + | DepLink_ExtUnit {-# UNPACK #-} !UnitId + data DependencyWriter = DependencyWriter { dw_beginWriter :: IO DepSink , dw_endWriter :: IO () @@ -223,6 +235,7 @@ data DependencyWriter = DependencyWriter data DepSink = DepSink { ds_writeDependency :: DepNode -> [Dep] -> IO () + , ds_writeLinkDependency :: DepLink -> IO () } ----------------------------------------------------------------- @@ -261,7 +274,21 @@ processDeps hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node)) mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _ _ sinks (AcyclicSCC (LinkNode keys unitId)) = do + let + toLinkNodeDep = \ case + NodeKey_Unit iu -> DepLink_Unit $ virtualUnitId iu + NodeKey_Module node -> DepLink_Module (mnkModuleName node) (mnkUnitId node) + NodeKey_Link uid -> DepLink_HomeUnit uid + NodeKey_ExternalUnit uid -> DepLink_ExtUnit uid + + linkNode = DepLink + { link_nodes = map toLinkNodeDep keys + , link_output = unitId + } + + traverse_ (\ sink -> ds_writeLinkDependency sink linkNode) sinks + processDeps _ _ _ (AcyclicSCC (UnitNode {})) = return () processDeps _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) -- No dependencies needed for fixed modules (already compiled) @@ -385,8 +412,13 @@ initFileDepWriter logger root tmpfs dflags makefile = do files <- beginMkDependHS logger tmpfs dflags makefile pure DependencyWriter { dw_beginWriter = do - pure $ DepSink $ \ node deps -> do - writeDependencies root (mkd_tmp_hdl files) suffixes node deps + pure DepSink + { ds_writeDependency = \ node deps -> do + writeDependencies root (mkd_tmp_hdl files) suffixes node deps + , ds_writeLinkDependency = \ _linkNode -> do + -- Link nodes are not supported + pure () + } , dw_endWriter = endMkDependHS logger files } where @@ -559,8 +591,13 @@ initJsonDepWriter logger tmpfs dflags output = do json_var <- mkJsonOutput logger tmpfs dflags output initDepJson pure DependencyWriter { dw_beginWriter = - pure $ DepSink $ \ node deps -> - writeHomeUnitDeps json_var node deps + pure DepSink + { ds_writeDependency = \ node deps -> + writeHomeUnitDeps json_var node deps + , ds_writeLinkDependency = \ link -> + -- Link nodes are not supported + writeLinkNode json_var link + } , dw_endWriter = do writeJsonOutput logger json_var } @@ -629,8 +666,12 @@ writeJsonOutput logger JsonOutput {json_path, json_tmp_file, json_tmp_hdl} = do -- Output helpers writeJsonl :: ToJson a => JsonOutput -> a -> IO () -writeJsonl JsonOutput {json_tmp_hdl} output = do - hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON $ json output) +writeJsonl deps_json output = do + writeJsonl' deps_json (json output) + +writeJsonl' :: JsonOutput -> JsonDoc -> IO () +writeJsonl' JsonOutput {json_tmp_hdl} output = do + hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON output) -------------------------------------------------------------------------------- -- Payload for -dep-json @@ -835,6 +876,47 @@ writeHomeUnitDeps deps_json DepNode {..} deps = do DepCpp {dep_path} -> (extDeps, addCpp dep_path node_data) +writeLinkNode :: JsonOutput -> DepLink -> IO () +writeLinkNode dep_json (DepLink uid deps) = do + writeJsonl' dep_json $ + JSObject + [ ("unit-id", JSString $ unitIdString uid) + , ("deps", JSArray $ concat + [ map renderMods (Map.toList allMods) + , map (JSString . unitIdString) (Set.toList units) + , map (JSString . unitIdString) (Set.toList homeUids) + , map (JSString . unitIdString) (Set.toList extUids) + ]) + ] + where + (extUids, homeUids, units, allMods) = foldl' go (Set.empty, Set.empty, Set.empty, Map.empty) deps + + renderMods (u, ms) = + JSObject + [ ("unit-id", JSString $ unitIdString u) + , ("modules", JSArray $ map (JSString . moduleKey) (Set.toList ms)) + ] + + + go (ext, homeUid, unit, mods) = \ case + DepLink_Module modName u -> + let + newMods = Map.insertWith (Set.union) u (Set.singleton modName) mods + in + (ext, homeUid, unit, newMods) + DepLink_Unit uid -> + (ext, homeUid, Set.insert uid unit, mods) + DepLink_HomeUnit uid -> + (ext, Set.insert uid homeUid, unit, mods) + DepLink_ExtUnit uid -> + (Set.insert uid ext, homeUid, unit, mods) + + moduleKey :: ModuleNameWithIsBoot -> String + moduleKey t = moduleNameString (gwib_mod t) ++ case (gwib_isBoot t) of + IsBoot -> "[boot]" + NotBoot -> "" + + ----------------------------------------------------------------- -- Module cycles ----------------------------------------------------------------- ===================================== testsuite/tests/driver/mkdepend/all.T ===================================== @@ -30,6 +30,13 @@ test('mkdepend_mhu03', , when(opsys('mingw32'), skip) # shell script preprocessor ], make_depend_multiunit, [['mhu03/unitA'], '']) +# Link nodes +test('mkdepend_mhu04', + [ extra_files(['mhu04/']), dep_makefile, dep_json ], + make_depend_multiunit, [['mhu04/unitLib', 'mhu04/unitApp'], '']) +test('mkdepend_mhu05', + [ extra_files(['mhu05/']), dep_makefile, dep_json ], + make_depend_multiunit, [['mhu05/unitLib', 'mhu05/unitApp', 'mhu05/unitTest'], '']) # Honour -F test('mkdepend01', ===================================== testsuite/tests/driver/mkdepend/mhu04/app/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main (main) where + +import Lib (greeting) +import Utils (shout) + +main :: IO () +main = putStrLn (shout greeting) ===================================== testsuite/tests/driver/mkdepend/mhu04/app/Utils.hs ===================================== @@ -0,0 +1,6 @@ +module Utils (shout) where + +import Data.Char (toUpper) + +shout :: String -> String +shout = map toUpper ===================================== testsuite/tests/driver/mkdepend/mhu04/lib/Lib.hs ===================================== @@ -0,0 +1,6 @@ +module Lib (greeting) where + +import Lib.Internal (name) + +greeting :: String +greeting = "Hello, " ++ name ===================================== testsuite/tests/driver/mkdepend/mhu04/lib/Lib/Internal.hs ===================================== @@ -0,0 +1,4 @@ +module Lib.Internal (name) where + +name :: String +name = "world" ===================================== testsuite/tests/driver/mkdepend/mhu04/unitApp ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu04/app -this-unit-id app -this-package-name app -package-id lib -o app Main ===================================== testsuite/tests/driver/mkdepend/mhu04/unitLib ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu04/lib -this-unit-id lib -this-package-name lib Lib Lib.Internal ===================================== testsuite/tests/driver/mkdepend/mhu05/app/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main (main) where + +import Lib (greeting) + +main :: IO () +main = putStrLn greeting ===================================== testsuite/tests/driver/mkdepend/mhu05/lib/Lib.hs ===================================== @@ -0,0 +1,6 @@ +module Lib (greeting) where + +import Lib.Internal (name) + +greeting :: String +greeting = "Hello, " ++ name ===================================== testsuite/tests/driver/mkdepend/mhu05/lib/Lib/Internal.hs ===================================== @@ -0,0 +1,4 @@ +module Lib.Internal (name) where + +name :: String +name = "world" ===================================== testsuite/tests/driver/mkdepend/mhu05/test/Spec.hs ===================================== @@ -0,0 +1,9 @@ +module Spec (main) where + +import Lib (greeting) +import Lib.Internal (name) + +main :: IO () +main + | greeting == "Hello, " ++ name = putStrLn "OK" + | otherwise = error "unexpected greeting" ===================================== testsuite/tests/driver/mkdepend/mhu05/unitApp ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/app -this-unit-id app -this-package-name app -package-id lib -o app Main ===================================== testsuite/tests/driver/mkdepend/mhu05/unitLib ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/lib -this-unit-id lib -this-package-name lib -staticlib Lib Lib.Internal ===================================== testsuite/tests/driver/mkdepend/mhu05/unitTest ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/test -this-unit-id test -this-package-name test -package-id lib -main-is Spec -o test Spec ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-json ===================================== @@ -0,0 +1,55 @@ +{ + "imports": {}, + "includes": [], + "module": "Lib.Internal", + "package-name": "lib", + "source": "mhu04/lib/Lib/Internal.hs", + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib.Internal" + ] + }, + "includes": [], + "module": "Lib", + "package-name": "lib", + "source": "mhu04/lib/Lib.hs", + "unit-id": "lib" +} +{ + "imports": {}, + "includes": [], + "module": "Utils", + "package-name": "app", + "source": "mhu04/app/Utils.hs", + "unit-id": "app" +} +{ + "imports": { + "app": [ + "Utils" + ], + "lib": [ + "Lib" + ] + }, + "includes": [], + "module": "Main", + "package-name": "app", + "source": "mhu04/app/Main.hs", + "unit-id": "app" +} +{ + "deps": [ + { + "modules": [ + "Main", + "Utils" + ], + "unit-id": "app" + } + ], + "unit-id": "app" +} ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-makefile ===================================== @@ -0,0 +1,9 @@ +# DO NOT DELETE: Beginning of Haskell dependencies +mhu04/lib/Lib/Internal.o : mhu04/lib/Lib/Internal.hs +mhu04/lib/Lib.o : mhu04/lib/Lib.hs +mhu04/lib/Lib.o : mhu04/lib/Lib/Internal.hi +mhu04/app/Utils.o : mhu04/app/Utils.hs +mhu04/app/Main.o : mhu04/app/Main.hs +mhu04/app/Main.o : mhu04/app/Utils.hi +mhu04/app/Main.o : mhu04/lib/Lib.hi +# DO NOT DELETE: End of Haskell dependencies ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-json ===================================== @@ -0,0 +1,79 @@ +{ + "imports": {}, + "includes": [], + "module": "Lib.Internal", + "package-name": "lib", + "source": "mhu05/lib/Lib/Internal.hs", + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib.Internal" + ] + }, + "includes": [], + "module": "Lib", + "package-name": "lib", + "source": "mhu05/lib/Lib.hs", + "unit-id": "lib" +} +{ + "deps": [ + { + "modules": [ + "Lib", + "Lib.Internal" + ], + "unit-id": "lib" + } + ], + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib" + ] + }, + "includes": [], + "module": "Main", + "package-name": "app", + "source": "mhu05/app/Main.hs", + "unit-id": "app" +} +{ + "deps": [ + { + "modules": [ + "Main" + ], + "unit-id": "app" + } + ], + "unit-id": "app" +} +{ + "imports": { + "lib": [ + "Lib", + "Lib.Internal" + ] + }, + "includes": [], + "module": "Spec", + "package-name": "test", + "source": "mhu05/test/Spec.hs", + "unit-id": "test" +} +{ + "deps": [ + { + "modules": [ + "Spec" + ], + "unit-id": "test" + } + ], + "unit-id": "test" +} ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-makefile ===================================== @@ -0,0 +1,10 @@ +# DO NOT DELETE: Beginning of Haskell dependencies +mhu05/lib/Lib/Internal.o : mhu05/lib/Lib/Internal.hs +mhu05/lib/Lib.o : mhu05/lib/Lib.hs +mhu05/lib/Lib.o : mhu05/lib/Lib/Internal.hi +mhu05/app/Main.o : mhu05/app/Main.hs +mhu05/app/Main.o : mhu05/lib/Lib.hi +mhu05/test/Spec.o : mhu05/test/Spec.hs +mhu05/test/Spec.o : mhu05/lib/Lib/Internal.hi +mhu05/test/Spec.o : mhu05/lib/Lib.hi +# DO NOT DELETE: End of Haskell dependencies View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/411a916737c3509cbc53f29cec5c25f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/411a916737c3509cbc53f29cec5c25f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/async-rpc] 5 commits: Asynchronous RPC with external interpreter
by Rodrigo Mesquita (＠alt-romes) 15 Oct '26

15 Oct '26

Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 1210c80c by Rodrigo Mesquita at 2026-10-15T12:02:13+01:00 Asynchronous RPC with external interpreter There's a single pipe to connect the host compiler to the external interpreter. On this pipe, we have historically done synchronous request/reply communication to invoke methods on the external interpreter. However, with the advent of multi-threaded debugging, it has become necessary to do asynchronous calls on the external interpreter, where we may block on the host waiting for a reply, but the external interpreter should handle the request asynchronously and reply when ready. For instance, we want to start the evaluation of the debuggee but not block the interpreter waiting for it to finish or hit a breakpoint. Or e.g. we want to resume two threads of the debuggee simulatenously instead of blocking waiting for the resume result of each one sequentially. And it turns out, we were already doing some ad-hoc asynchronous communication to evaluate Template Haskell on the external interpreter. It used to go as an ad-hoc "send request without expecting reply", followed by handling on the host a set of 'THMessage's sent by the interpreter, followed by "expect a response to arrive now". It worked because there was still a fixed order of messages, but it fits an async model in a non-ad-hoc way. Asynchronous communication that unblocks the external interpreter main thread will also make it possible to resolve issues such as #18852 (exceptions leaving the external interpreter in an unrecoverrable state) The new design -------------- The new invariant: every single request should receive a matching reply. The pipe is bidirectional (the ext. interpreter can receive requests, but it can also send requests for TH evaluation; the host can send requests, but it can also receive TH requests from the interpreter). When a request is sent in whichever direction, it always contains a correlation-id header. The Sender places an empty MVar on a pending-reply map keyed by id and waits on it for a response. See 'remoteCall' and 'remoteTHCall'. The pipe is associated to a thread which drains the read end. Because it's bidirectional, two things may be read off the pipe: - A Reply, with a correlation-id header, which we match against the pending requests map to unblock the corresponding pending-reply MVar - A Request, which is queued to the pending-request queue. To handle a message, we take a Request from the pending-request queue and run a handler that produces a Reply. Currently, the handler is run synchronously in the thread, but it is trivial to make the handler run in a forked thread for certain ("interruptible") messages in an upcoming patch (when it is necessary for the multi-threaded debugger). See 'handleRemoteCall' and 'handleRemoteTHCall'. The old interp lock now just protect the pipe writing (reads don't lock bc they are done exclusively by drainPipe), it doesn't need nor should lock the full remote procedure call. - - - - - 01640eec by Rodrigo Mesquita at 2026-10-15T12:02:13+01:00 interp: Add separate mailboxes for TH async RPC When the host sends a `RunTH` command to the interpreter, it expects a few "reverse requests" from the interpreter (e.g. `NewName`) which must be run in the same context that initiated the `RunTH`. When the host is evaluating many splices at once, it will send many `RunTH` commands to the interpreter and start listening for reverse requests in the meantime. However, a received request previously had no way to be associated to the scope of a particular `RunTH` invocation, so the reverse commands could get replied to from incorrect contexts, or e.g. a `RunTHDone` from the interp. could terminate early the wrong `RunTH` computation. In this commit we add independent mailboxes to the interpreter asynchronous RPC infrastructure, allowing a RunTH to announce a particular `InboxId` that all reverse requests for that RunTH should use. On the host, we create that mailbox id and have `handleRemoteTHCall` listen on that specific mailbox rather than for requests without a specific mailbox address. - - - - - ea5bd12e by Rodrigo Mesquita at 2026-10-15T12:02:14+01:00 refactor: Move Async RPC abstraction into GHCi.Message.Async Carves out the Async RPC over the Pipe abstraction to a new module, making the GHCi.Message more about the specific interpreter messages rather than about the IPC protocol. - - - - - 48377e28 by Rodrigo Mesquita at 2026-10-15T12:02:14+01:00 interp: If we have pending reads in the queue we can deliver them We may still be able to reply even if the read end was closed. As long as we have pending messages we should try to deliver them. - - - - - cd423df8 by Andrea Vezzosi at 2026-10-15T12:03:25+01:00 interp: close Handles when done with Pipe Ensures we close the pipe handles (if created using 'mkPipeFromHandles') on `closePipe`, and do `closePipe` on `Shutdown`. The thread draining the read end always `'finally'` closes the read end. And `closePipe` kills the draining thread and closes the write end. When `remoteAsyncReq`, we throw PipeReadClosedException if the pipe read is closed, since we wouldn't be able to receive the reply. It's fine for the drain thread not to close the write end, even if it dies without `closePipe` (which does close the write end), because: - requests pending a reply will get PipeClosedException (we'll not be able to read any further "real" reply) - new calls to `remoteAsyncReq` will throw PipeReadClosedException - pending pipe writes, in response to an already read request, might still succeed And the clean up code should call close pipe to ensure the write end is closed as well. So, if the drain thread dies naturally and the read end is closed, may still be attempted to be used, but it will throw accordingly. The user likely wants to catch this to close the write end as well. - - - - - 12 changed files: - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Runtime/Interpreter/Process.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - compiler/GHC/Tc/Gen/Splice.hs - libraries/ghci/GHCi/Message.hs - + libraries/ghci/GHCi/Message/Async.hs - libraries/ghci/GHCi/Server.hs - libraries/ghci/GHCi/TH.hs - libraries/ghci/ghci.cabal.in - testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs Changes: ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -626,11 +626,9 @@ spawnIServ conf = do [] (iservConfOpts conf) interpPipe <- mkPipeFromHandles rh wh - lock <- newMVar () let process = InterpProcess { interpHandle = ph , interpPipe - , interpLock = lock } pending_frees <- newMVar [] @@ -656,6 +654,8 @@ stopInterp interp = case interpInstance interp of if isJust ex then pure () else sendMessage i Shutdown + -- We asked the server to shutdown, so we will also shutdown any communication. + closePipe (interpPipe (instProcess i)) pure InterpPending -- ----------------------------------------------------------------------------- ===================================== compiler/GHC/Runtime/Interpreter/JS.hs ===================================== @@ -127,11 +127,9 @@ startTHRunnerProcess interp_js settings = do std_in <- readIORef interp_in interpPipe <- mkPipeFromHandles rh wh - lock <- newMVar () let proc = InterpProcess { interpHandle = hdl , interpPipe - , interpLock = lock } pure (std_in, proc) @@ -382,7 +380,7 @@ jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan = do -- Haskell server. server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst)) if server_started - then sendMessageNoResponse inst $ LoadObj all_js + then sendMessage inst $ LoadObj all_js else jsLoadFile inst all_js ---------------------------------------------------------------- ===================================== compiler/GHC/Runtime/Interpreter/Process.hs ===================================== @@ -2,16 +2,8 @@ module GHC.Runtime.Interpreter.Process ( -- * Message API Message(..) - , DelayedResponse (..) - -- * Top-level message API (these acquire/release a lock) , sendMessage - , sendMessageNoResponse - , sendMessageDelayedResponse - , receiveDelayedResponse - -- * Nested message API (these require the interpreter to already be locked) - , sendAnyValue - , receiveAnyValue - , receiveTHMessage + , sendTHComputation ) where @@ -27,97 +19,63 @@ import GHC.Utils.Exception as Ex import Data.Binary import System.Exit import System.Process -import Control.Concurrent.MVar (MVar, withMVar, takeMVar, putMVar, isEmptyMVar) - -data DelayedResponse a = DelayedResponse +import Control.Concurrent +import Data.IORef +import Control.Concurrent.STM -- ----------------------------------------------------------------------------- -- Top-level Message API --- | Send a message to the interpreter process that doesn't expect a response --- (locks the interpreter while sending) -sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO () -sendMessageNoResponse i m = - withLock i $ writeInterpProcess (instProcess i) (putMessage m) - --- | Send a message to the interpreter that expects a response --- (locks the interpreter while until the response is received) +-- | Send a message to the interpreter and expect a response, blocking until it arrives. +-- +-- This issues an asynchronous RPC on the external interpreter which does not +-- block the external interpreter thread. We block here on the host because we +-- wait for the asynchronous response to arrive. sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a -sendMessage i m = withLock i $ callInterpProcess (instProcess i) m - --- | Send a message to the interpreter process whose response is expected later +sendMessage i msg = + remoteCall (interpPipe proc) msg + `catchException` \(e :: SomeException) -> handleInterpProcessFailure proc e + where + proc = instProcess i + +-- | Send a message with a TH computation to the ext. interpreter (like +-- 'RunTH', or 'RunModFinalizers') and handle 'THMessage' requests from the +-- ext. interpreter to us in the meantime. -- --- This is useful to avoid forgetting to receive the value and to ensure that --- the type of the response isn't lost. Use receiveDelayedResponse to read it. --- (locks the interpreter until the response is received using --- `receiveDelayedResponse`) -sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a) -sendMessageDelayedResponse i m = do - lock i - writeInterpProcess (instProcess i) (putMessage m) - pure DelayedResponse - --- | Expect a delayed result to be received now -receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a -receiveDelayedResponse i DelayedResponse = do - ensureLocked i - r <- readInterpProcess (instProcess i) get - unlock i - pure r - --- ----------------------------------------------------------------------------- --- Nested Message API - --- | Send any value (requires locked interpreter) -sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO () -sendAnyValue i m = ensureLocked i >> writeInterpProcess (instProcess i) (put m) - --- | Expect a value to be received (requires locked interpreter) -receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a -receiveAnyValue i get = ensureLocked i >> readInterpProcess (instProcess i) get - --- | Wait for a Template Haskell message (requires locked interpreter) -receiveTHMessage :: ExtInterpInstance d -> IO THMsg -receiveTHMessage i = ensureLocked i >> receiveAnyValue i getTHMessage - --- ----------------------------------------------------------------------------- - -getLock :: ExtInterpInstance d -> MVar () -getLock = interpLock . instProcess - -withLock :: ExtInterpInstance d -> IO a -> IO a -withLock i f = withMVar (getLock i) (const f) - -lock :: ExtInterpInstance d -> IO () -lock i = takeMVar (getLock i) - -unlock :: ExtInterpInstance d -> IO () -unlock i = putMVar (getLock i) () - -ensureLocked :: ExtInterpInstance d -> IO () -ensureLocked i = - isEmptyMVar (getLock i) >>= \case - False -> panic "ensureLocked: external interpreter not locked" - _ -> pure () - - --- | Send a 'Message' and receive the response from the interpreter process -callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a -callInterpProcess i msg = - remoteCall (interpPipe i) msg - `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e - --- | Read a value from the interpreter process -readInterpProcess :: InterpProcess -> Get a -> IO a -readInterpProcess i get = - readPipe (interpPipe i) get - `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e - --- | Send a value to the interpreter process -writeInterpProcess :: InterpProcess -> Put -> IO () -writeInterpProcess i put = - writePipe (interpPipe i) put - `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e +-- This function blocks until the TH computation returns a value, but spawns in +-- the background a thread to handle the 'THMessage's until the TH computation +-- is fully done. +sendTHComputation + :: Binary a + => ExtInterpInstance d + -> (InboxId -> Message a) + -> (forall b. Binary b => THMessage b -> IO (Bool, b)) + -- ^ Handle one message. Return True to end the loop. + -- This handler must never uninterrutibly mask an expression which may get + -- stuck. If it does, then 'sendTHComputation' will also get uninterruptibly stuck. + -> IO a +sendTHComputation i msg reqHandler = mask $ \restore -> do + -- inline "withAsync/wait" + var <- newEmptyTMVarIO + mbox <- newMailbox (pipeAsyncMngr (interpPipe proc)) + ht <- forkFinally (restore (handlerLoop mbox)) (atomically . putTMVar var) + restore (sendMessage i (msg mbox) <* atomically (readTMVar var)) + `onException` uninterruptibleMask_ (throwTo ht CancelTHHandler) + where + proc = instProcess i + handleOne mbox doneRef = do + handleRemoteTHCall (interpPipe proc) mbox $ \req -> do + (stop, res) <- reqHandler req + writeIORef doneRef stop + return res + handlerLoop mbox = do + doneRef <- newIORef False + let loop = do + handleOne mbox doneRef + isDone <- readIORef doneRef + if isDone then return () + else loop + in loop handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a handleInterpProcessFailure i e = do @@ -130,3 +88,8 @@ handleInterpProcessFailure i e = do terminateProcess hdl _ <- waitForProcess hdl throw e + +data CancelTHHandler = CancelTHHandler deriving Show +instance Exception CancelTHHandler where + fromException = asyncExceptionFromException + toException = asyncExceptionToException ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -111,7 +111,6 @@ type WasmInterp = ExtInterpState WasmInterpConfig () data InterpProcess = InterpProcess { interpPipe :: !Pipe -- ^ Pipe to communicate with the server , interpHandle :: !ProcessHandle -- ^ Process handle of the server - , interpLock :: !(MVar ()) -- ^ Lock to prevent concurrent access to the stream } -- | Status of an external interpreter ===================================== compiler/GHC/Runtime/Interpreter/Wasm.hs ===================================== @@ -73,14 +73,12 @@ spawnWasmInterp WasmInterpConfig {..} = do hSetBuffering rh NoBuffering interpPipe <- mkPipeFromHandles rh wh pending_frees <- newMVar [] - lock <- newMVar () pure $ ExtInterpInstance { instProcess = InterpProcess { interpHandle = ph, - interpPipe, - interpLock = lock + interpPipe }, instPendingFrees = pending_frees, instExtra = () ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -170,6 +170,7 @@ import Data.IORef import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) +import Data.Function {- Note [Template Haskell state diagram] @@ -1165,11 +1166,12 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do case th_state of Nothing -> return () -- TH was not started, nothing to do Just fhv -> do - r <- liftIO $ withForeignRef fhv $ \st -> - withForeignRefs finRefs $ \qrefs -> - sendMessageDelayedResponse inst (RunModFinalizers st qrefs) - () <- runRemoteTH inst [] - qr <- liftIO $ receiveDelayedResponse inst r + qr <- withRunInIO $ \runInIO -> do + recovers <- newIORef [] + withForeignRef fhv $ \st -> + withForeignRefs finRefs $ \qrefs -> + sendTHComputation inst (\ii -> RunModFinalizers ii st qrefs) $ \msg -> + runInIO (runRemoteTH recovers msg) checkQResult qr runQResult @@ -1824,48 +1826,47 @@ runTH ty fhv = do rstate <- getTHState inst loc <- location -- run a remote TH request - r <- liftIO $ + qr <- withRunInIO $ \runInIO -> do + recovers <- newIORef [] withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc)) - -- respond to requests from the interpreter - runRemoteTH inst [] - -- get the final result - qr <- liftIO $ receiveDelayedResponse inst r + withForeignRef fhv $ \q_hv -> + sendTHComputation inst (\ii -> RunTH ii state_hv q_hv ty (Just loc)) $ \msg -> + runInIO (runRemoteTH recovers msg) bs <- checkQResult qr return $! runGet get (LB.fromStrict bs) --- | communicate with a remotely-running TH computation until it finishes. +-- | Communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH - :: ExtInterpInstance d - -> [Messages TcRnMessage] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH inst recovers = do - THMsg msg <- liftIO $ receiveTHMessage inst + :: Binary a + => IORef [Messages TcRnMessage] -- ^ saved from nested calls to qRecover + -> THMessage a + -> TcM (Bool, a) +runRemoteTH recovers msg = do case msg of - RunTHDone -> return () + RunTHDone -> return (True, ()) StartRecover -> do -- Note [TH recover with -fexternal-interpreter] v <- getErrsVar msgs <- readTcRef v writeTcRef v emptyMessages - runRemoteTH inst (msgs : recovers) + modifyIORef recovers (msgs:) & liftIO + return (False, ()) EndRecover caught_error -> do - let (prev_msgs, rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) + (prev_msgs, rest) <- liftIO $ + readIORef recovers >>= \case + [] -> panic "EndRecover" + a : b -> pure (a,b) v <- getErrsVar warn_msgs <- getWarningMessages <$> readTcRef v -- keep the warnings only if there were no errors writeTcRef v $ if caught_error then prev_msgs else mkMessages warn_msgs `unionMessages` prev_msgs - runRemoteTH inst rest + writeIORef recovers rest & liftIO + return (False, ()) _other -> do - r <- handleTHMessage msg - liftIO $ sendAnyValue inst r - runRemoteTH inst recovers + (False,) <$> handleTHMessage msg -- | Check a QResult checkQResult :: QResult a -> TcM a ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -1,6 +1,7 @@ -{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, - CPP, NamedFieldPuns #-} +{-# LANGUAGE RecursiveDo, GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, CPP, + NamedFieldPuns, LambdaCase, TypeAbstractions, TypeApplications, + LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections, MagicHash #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -22,7 +23,16 @@ module GHCi.Message , ResumeContext(..) , QState(..) , getMessage, putMessage, getTHMessage, putTHMessage - , Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe + + , Pipe(..), mkPipeFromHandles, mkPipeFromContinuations, closePipe + , remoteCall, remoteTHCall + , handleRemoteCall, handleRemoteTHCall + , RemoteProcessException(..), PipeClosedException(..) + + , InboxId(..) + , newMailbox + , closeMailbox + , BreakModule , BreakUnitId , LoadedDLL @@ -45,18 +55,14 @@ import qualified GHC.Exts.Heap as Heap import GHC.ForeignSrcLang import GHC.Fingerprint import GHC.Conc (pseq, par) +import GHC.IO (IO(..)) import Control.Concurrent import Control.DeepSeq import Control.Exception -#if MIN_VERSION_base(4,20,0) -import Control.Exception.Context -#endif import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Short as BS import Data.Dynamic @@ -68,9 +74,7 @@ import GHC.Generics import GHC.Stack.CCS import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH -import System.Exit -import System.IO -import System.IO.Error +import GHCi.Message.Async -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -214,14 +218,16 @@ data Message a where -- they did, we have to serialize the value anyway, so we might -- as well serialize it to force it. RunTH - :: RemoteRef (IORef QState) + :: InboxId -- ^ announce mailbox for related 'remoteTHCall's + -> RemoteRef (IORef QState) -> HValueRef {- e.g. TH.Q TH.Exp -} -> THResultType -> Maybe TH.Loc -> Message (QResult ByteString) -- | Run the given mod finalizers. - RunModFinalizers :: RemoteRef (IORef QState) + RunModFinalizers :: InboxId -- ^ announce mailbox for related 'remoteTHCall's + -> RemoteRef (IORef QState) -> [RemoteRef (TH.Q ())] -> Message (QResult ()) @@ -458,45 +464,6 @@ data BreakUnitId -- | A dummy type that tags pointers returned by 'LoadDLLs'. data LoadedDLL --- SomeException can't be serialized because it contains dynamic --- types. However, we do very limited things with the exceptions that --- are thrown by interpreted computations: --- --- * We print them, e.g. "*** Exception: <something>" --- * UserInterrupt has a special meaning --- * In ghc -e, exitWith should exit with the appropriate exit code --- --- So all we need to do is distinguish UserInterrupt and ExitCode, and --- all other exceptions can be represented by their 'show' string. --- -data SerializableException - = EUserInterrupt - | EExitCode ExitCode - | EOtherException String - deriving (Generic, Show) - -toSerializableException :: SomeException -> SerializableException -toSerializableException ex - | Just UserInterrupt <- fromException ex = EUserInterrupt - | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) - | otherwise = EOtherException $ -#if MIN_VERSION_base(4,20,0) - -- Exception plus backtrace as seen in `displayExceptionWithInfo` - case displayExceptionContext (someExceptionContext ex) of - "" -> displayException (ex :: SomeException) - cx -> displayException (ex :: SomeException) ++ "\n\n" ++ cx -#else - show (ex :: SomeException) -#endif - -fromSerializableException :: SerializableException -> SomeException -fromSerializableException EUserInterrupt = toException UserInterrupt -fromSerializableException (EExitCode c) = toException c -fromSerializableException (EOtherException str) = toException (ErrorCall str) - -instance Binary ExitCode -instance Binary SerializableException - data THResult a = THException String | THComplete a @@ -513,11 +480,13 @@ instance Binary THResultType -- StartTH message. A new one is created per module that GHC -- typechecks. data QState = QState - { qsMap :: Map TypeRep Dynamic + { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module - , qsLocation :: Maybe TH.Loc + , qsLocation :: Maybe TH.Loc -- ^ location for current splice, if any - , qsPipe :: Pipe + , qsInboxId :: InboxId + -- ^ the mailbox expecting requests for each RunTH-like run + , qsPipe :: Pipe -- ^ pipe to communicate with GHC } instance Show QState where show _ = "<QState>" @@ -600,9 +569,9 @@ getMessage = do 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH - 32 -> Msg <$> (RunModFinalizers <$> get <*> get) + 32 -> Msg <$> (RunModFinalizers <$> get <*> get <*> get) 33 -> Msg <$> (AddSptEntry <$> get <*> get) - 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) + 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get <*> get) 35 -> Msg <$> (GetClosure <$> get) 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs @@ -648,9 +617,9 @@ putMessage m = case m of BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 - RunModFinalizers a b -> putWord8 32 >> put a >> put b + RunModFinalizers a b c -> putWord8 32 >> put a >> put b >> put c AddSptEntry a b -> putWord8 33 >> put a >> put b - RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty + RunTH ii st q loc ty -> putWord8 34 >> put ii >> put st >> put q >> put loc >> put ty GetClosure a -> putWord8 35 >> put a Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 @@ -688,73 +657,40 @@ serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos) chunkList _ [] = [] chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs --- ----------------------------------------------------------------------------- --- Reading/writing messages - --- | An opaque pipe for bidirectional binary data transmission. -data Pipe = Pipe - { getSome :: !(IO ByteString) - , putAll :: !(B.Builder -> IO ()) - , pipeLeftovers :: !(IORef (Maybe ByteString)) - } - --- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. -mkPipeFromHandles :: Handle -> Handle -> IO Pipe -mkPipeFromHandles pipeRead pipeWrite = do - let getSome = B.hGetSome pipeRead (32*1024) - putAll b = do - B.hPutBuilder pipeWrite b - hFlush pipeWrite - pipeLeftovers <- newIORef Nothing - pure $ Pipe { getSome, putAll, pipeLeftovers } - --- | Make a 'Pipe' from a reader function and a writer function. -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe -mkPipeFromContinuations getSome putAll = do - pipeLeftovers <- newIORef Nothing - pure $ Pipe { getSome, putAll, pipeLeftovers } - +-- | Send a 'Message' request to and wait for a reply from the interpreter +-- (blocks on the calling side, doesn't necessarily block the interpreter) remoteCall :: Binary a => Pipe -> Message a -> IO a -remoteCall pipe msg = do - writePipe pipe (putMessage msg) - readPipe pipe get - -writePipe :: Pipe -> Put -> IO () -writePipe Pipe{..} put = putAll $ execPut put - -remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a -remoteTHCall pipe msg = do - writePipe pipe (putTHMessage msg) - readPipe pipe get - -readPipe :: Pipe -> Get a -> IO a -readPipe Pipe{..} get = do - leftovers <- readIORef pipeLeftovers - m <- getBin getSome get leftovers - case m of - Nothing -> throw $ - mkIOError eofErrorType "GHCi.Message.readPipe" Nothing Nothing - Just (result, new_leftovers) -> do - writeIORef pipeLeftovers new_leftovers - return result - -getBin - :: (IO ByteString) -> Get a -> Maybe ByteString - -> IO (Maybe (a, Maybe ByteString)) - -getBin getsome get leftover = go leftover (runGetIncremental get) - where - go Nothing (Done leftover _ msg) = - return (Just (msg, if B.null leftover then Nothing else Just leftover)) - go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers") - go (Just leftover) (Partial fun) = do - go Nothing (fun (Just leftover)) - go Nothing (Partial fun) = do - -- putStrLn "before hGetSome" - b <- getsome - -- putStrLn $ "hGetSome: " ++ show (B.length b) - if B.null b - then return Nothing - else go Nothing (fun (Just b)) - go _lft (Fail _rest _off str) = - throwIO (ErrorCall ("getBin: " ++ str)) +remoteCall pipe msg = either throwIO (pure . runGet get) + =<< remoteAsyncReq pipe (putMessage msg) Nothing + +-- | Handle a single 'Message' request on the interpreter and reply to the host +handleRemoteCall :: Pipe + -> (Msg -> IO Msg) {-^ Msg hook -} + -> (forall a. (Show a, Binary a) => Message a -> IO a) + -> IO () +handleRemoteCall pipe hook k = + handleAsyncReq pipe getMessage Nothing \writer msg0 -> IO \s0 -> + case hook msg0 |#> s0 of -- unIO for linearity checking + (# s1, Msg msg #) -> case k msg |#> s1 of + (# s2, a #) -> writeReply writer (put a) |#> s2 + +-- | Send a 'THMessage' request to the host and wait for a reply from the host +-- to the interpreter. +-- +-- A 'THMessage' request from the interpreter is always associated with a +-- 'RunTH'-like run. Since the host may have many in-flight TH runs, we always +-- want a specific host 'InboxId' (which is announced in the 'RunTH' request) +remoteTHCall :: Binary a => Pipe -> InboxId -> THMessage a -> IO a +remoteTHCall pipe ii msg = either throwIO (pure . runGet get) + =<< remoteAsyncReq pipe (putTHMessage msg) (Just ii) + +-- | Handle a 'THMessage' request on the host and reply to the interpreter. +-- Symmterically to 'remoteTHCall', we always want to specify the 'InboxId' for +-- RunTH "reverse requests" +handleRemoteTHCall + :: Pipe -> InboxId -> (forall a. (Show a, Binary a) => THMessage a -> IO a) -> IO () +handleRemoteTHCall pipe ii k = + handleAsyncReq pipe getTHMessage (Just ii) \writer (THMsg msg) -> IO \s0 -> + case k msg |#> s0 of -- unIO for linearity checking + (# s1, a #) -> writeReply writer (put a) |#> s1 + ===================================== libraries/ghci/GHCi/Message/Async.hs ===================================== @@ -0,0 +1,498 @@ +{-# LANGUAGE RecursiveDo, GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, CPP, + NamedFieldPuns, LambdaCase, TypeAbstractions, TypeApplications, + LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections, MagicHash #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +module GHCi.Message.Async + ( + -- * Pipes + Pipe(..), mkPipeFromHandles, mkPipeFromContinuations + , closePipe, PipeReadClosedException(..) + + -- * Interface for async bidirectional RPC + , remoteAsyncReq, handleAsyncReq + , RemoteProcessException(..), DecodeAsyncReqException(..) + + -- ** Mailboxes + , InboxId(..) + , newMailbox + , closeMailbox + + -- ** Async matching internals + , AsyncManager(..), CorrelationId + , IddMsg(..), newAsyncManager + + -- ** Consume `reply` exactly once + , WriteReply(..) + , writeReply, (|#>) + + -- * Serializable exceptions + , SerializableException(..) + , toSerializableException, fromSerializableException + ) where + +import Prelude -- See note [Why do we import Prelude here?] +import GHCi.TH.Binary () -- For Binary instances + +import GHC.IO (IO(..)) +import Control.Concurrent +import Control.Exception +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Context +#endif +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as LB +import Data.IORef +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.Generics +import System.Exit +import System.IO +import Control.Monad +import Control.Concurrent.STM +import Data.Bifunctor +import GHC.Base (State#) +import GHC.Exts (RealWorld) + +-------------------------------------------------------------------------------- +-- * Reading/writing and Pipes +-------------------------------------------------------------------------------- + +-- | An opaque pipe for bidirectional binary data transmission. +data Pipe = Pipe + { getSome :: !(IO ByteString) + , putAll :: !(B.Builder -> IO ()) + , pipeLeftovers :: !(IORef (Maybe ByteString)) + , pipeLock :: !(MVar ()) -- ^ Lock to prevent concurrent writes to the stream + , pipeAsyncMngr :: !AsyncManager + , pipeCloseRead :: !(IO ()) + -- ^ closes read end of the pipe + , pipeCloseWrite :: !(IO ()) + -- ^ closes write end of the pipe + , pipeReadClosed :: !(TVar Bool) + -- ^ After the pipe is closed, messages can no longer be received from the + -- other end, but the 'AsyncManager' queues might not be empty yet. + } + +-- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. +-- Must call 'closePipe' at the end to clean up. +mkPipeFromHandles :: Handle -> Handle -> IO Pipe +mkPipeFromHandles pipeRead pipeWrite = do + let getSome = B.hGetSome pipeRead (32*1024) + putAll b = do + B.hPutBuilder pipeWrite b + hFlush pipeWrite + mkPipeFromContinuations getSome putAll (hClose pipeRead) (hClose pipeWrite) + +-- | Make a 'Pipe' from a reader function and a writer function. +-- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'. +mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) + -> IO () + -- ^ pipeCloseRead + -> IO () + -- ^ pipeCloseWrite + -> IO Pipe +mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo + pipeLeftovers <- newIORef Nothing + pipeLock <- newMVar () + pipeReadClosed <- newTVarIO False + mdo + pipeAsyncMngr <- newAsyncManager p + let p = Pipe { .. } + pure p + +-- | Cleanly close our ends of the Pipe, terminating the async manager's +-- drain-read-end thread. Also calls 'pipeCloseRead' and 'pipeCloseWrite', in that order. +-- +-- If the pipe was created using 'mkPipeFromHandles', the handles are also closed. +-- +-- The requests we've sent that are pending are all canceled with +-- 'PipeReadClosedException' by ourselves. +-- +-- No special notification is sent to the remote process, a message to that +-- effect should be sent ahead of time if one is needed (see 'Shutdown'). +closePipe :: Pipe -> IO () +closePipe Pipe{..} = do + + readAlreadyClosed <- atomically $ swapTVar pipeReadClosed True + + -- this triggers pipeCloseRead + unless readAlreadyClosed $ do + + -- releases handle lock taken by reading, and cleans up by replying to every + -- pending request with 'PipeReadClosedException'. + throwTo (asyncDrainTid pipeAsyncMngr) PipeReadClosedException + + pipeCloseWrite + +-- | We've closed the pipe read end on this process +data PipeReadClosedException = PipeReadClosedException deriving Show +instance Exception PipeReadClosedException + +-------------------------------------------------------------------------------- +-- ** Pipe thread-safe read/write +-------------------------------------------------------------------------------- +-- All messages on the wire are 'IddMsg', which contain a correlation header +-- and identify whether they are requests or replies. + +writePipe :: Pipe -> IddMsg -> IO () +writePipe p@Pipe{..} = withLock p . putAll . execPut . put + +-- | Only the 'drainPipe' thread should read from the pipe directly. Other +-- functions should wait for the matching reply to be delivered asynchronously. +-- (see 'withAsyncReq'). It doesn't lock to read bc it assumes single reader is 'drainPipe'. +-- +-- Returns @Nothing@ on EOF. +readPipe :: Pipe -> IO (Maybe IddMsg) +readPipe Pipe{..} = do + leftovers <- readIORef pipeLeftovers + m <- getBin getSome get leftovers + case m of + Nothing -> return Nothing + Just (result, new_leftovers) -> do + writeIORef pipeLeftovers new_leftovers + return (Just result) + +getBin + :: (IO ByteString) -> Get a -> Maybe ByteString + -> IO (Maybe (a, Maybe ByteString)) + +getBin getsome get leftover = go leftover (runGetIncremental get) + where + go Nothing (Done leftover _ msg) = + return (Just (msg, if B.null leftover then Nothing else Just leftover)) + go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers") + go (Just leftover) (Partial fun) = do + go Nothing (fun (Just leftover)) + go Nothing (Partial fun) = do + -- putStrLn "before hGetSome" + b <- getsome + -- putStrLn $ "hGetSome: " ++ show (B.length b) + if B.null b + then return Nothing + else go Nothing (fun (Just b)) + go _lft (Fail _rest _off str) = + throwIO (ErrorCall ("getBin: " ++ str)) + +withLock :: Pipe -> IO c -> IO c +withLock Pipe{..} = bracket (takeMVar pipeLock) (putMVar pipeLock) . const + +-------------------------------------------------------------------------------- +-- * Matching requests with async replies +-------------------------------------------------------------------------------- + +-- | Send an asynchronous request and block waiting for a matching reply +remoteAsyncReq :: Pipe -> Put -> (Maybe InboxId) -> IO (Either SomeException LB.ByteString) +remoteAsyncReq pipe msg ii = do + + let pendingReplies = pendingReply (pipeAsyncMngr pipe) + + -- Mark pending request + uq <- freshId (pipeAsyncMngr pipe) + wv <- newEmptyTMVarIO + + isClosed <- atomically $ do + isClosed <- readTVar (pipeReadClosed pipe) + -- don't send the req if we won't get a reply. + if isClosed + then pure True + else do + modifyTVar pendingReplies (IntMap.insert uq wv) + pure False + + when isClosed $ do + throwIO PipeReadClosedException + + -- Write request + writePipe pipe (Request uq ii (runPut msg)) + `onException` + -- the req wasn't done, or no one will be reading the reply: + -- in either case, drop it from the pending map. + atomically (modifyTVar pendingReplies (IntMap.delete uq)) + + -- Block waiting for reply + atomically (takeTMVar wv) + `onException` + atomically (modifyTVar pendingReplies (IntMap.delete uq)) + +-- | Receive a single asynchronous request and send a matching reply +-- asynchronously (the handler may fork a computation that eventually replies +-- and can return before actually replying, as long as it eventually does). +-- +-- The handler receives as an argument the function to use to reply to the request. +-- It must be used exactly once (all requests expect a reply, and you can't +-- reply more than once). Linear types enforce the handler replies in every +-- branch, and if the handler otherwise throws, it is handled by 'handleAsyncReq'. +handleAsyncReq :: Pipe -> Get a -> (Maybe InboxId) -> (WriteReply Put %1 -> a -> IO r) -> IO r +handleAsyncReq pipe getit mii k = mask $ \restore -> do + let am = pipeAsyncMngr pipe + ack <- newEmptyMVar + + -- Block waiting for request + mbreq <- atomically $ do + isClosed <- readTVar (pipeReadClosed pipe) + taken <- case mii of + Nothing -> tryReadTQueue $ requestsQueue am + Just ii -> tryReadTQueue =<< getMailbox am ii + case taken of + Just req -> pure (Just req) + Nothing | isClosed -> pure Nothing -- empty and closed + | otherwise -> retry -- wait for msg + + case mbreq of + Nothing -> throwIO PipeReadClosedException -- can't expect reqs + Just (uq, bs) -> do + let reply p = do + writePipe pipe (Reply uq (bimap toSerializableException runPut p)) + putMVar ack () + + -- Run the continuation which must reply exactly once with 'writeReply' + case runGetOrFail getit bs of + Left (_, _, err) -> do + let exc = DecodeAsyncReqException err + reply (Left (toException exc)) + throwIO exc + Right (_, _, it) -> + restore (k (WriteReply reply) it) + + -- If there's an exception before the reply is sent, reply with an error instead. + `catch` \(e :: SomeException) -> do + + tryTakeMVar ack >>= \case + Just () -> + -- Already replied + throwIO e + Nothing -> do + -- Reply with an error + reply (Left e) + throwIO e + +-- | 'handleSyncReq' failed to decode an incoming request payload using the given @'Get' a@ +newtype DecodeAsyncReqException = DecodeAsyncReqException String deriving Show +instance Exception DecodeAsyncReqException + + +-- ** Mailboxes ---------------------------------------------------------------- + +-- | A 'Request' may optionally declare an 'InboxId'. If it does, it can only +-- be read by a 'handleAsyncReq' for that specific 'InboxId'. That is, +-- @'handleAsyncReq' p get Nothing@ will not receive messages meant for a +-- specific inbox. +-- +-- This is useful to prevent mixing up reverse requests, where we want to send +-- many reverse requests but have the caller handle them without interleaving +-- them. +newtype InboxId = InboxId Int deriving (Show, Binary) + +-- | Create a new mailbox from where we can read all requests addressed to this 'InboxId'. +newMailbox :: AsyncManager -> IO InboxId +newMailbox am = InboxId <$> freshId am + -- `mailboxQueues` is written on demand, no need to do it here. + +-- | Clean up a created mailbox by 'InboxId'. +closeMailbox :: AsyncManager -> InboxId -> IO () +closeMailbox AsyncManager{..} (InboxId ii) = + atomically (modifyTVar mailboxQueues (IntMap.delete ii)) + +-- | Get or create a new mailbox for this 'InboxId' +getMailbox :: AsyncManager -> InboxId -> STM (TQueue (CorrelationId, LB.ByteString)) +getMailbox am (InboxId ii) = do + mboxes <- readTVar (mailboxQueues am) + case IntMap.lookup ii mboxes of + Nothing -> do + q <- newTQueue + writeTVar (mailboxQueues am) (IntMap.insert ii q mboxes) + pure q + Just q -> + pure q + +-- ** Async matching "internals" ----------------------------------------------- + +data AsyncManager = AsyncManager + { pendingReply :: !(TVar (IntMap (TMVar (Either SomeException LB.ByteString)))) + -- ^ When a request is sent, keep track that we're expecting a reply. The + -- TMVar is signaled when the reply arrives. The exception can originate + -- from the host process, or from the remote one (with 'RemoteProcessException'). + , requestsQueue :: !(TQueue (CorrelationId, LB.ByteString)) + -- ^ A queue of pending received requests. When a request is received + -- /without/ a specific 'InboxId', queue it here. A request handler will + -- pop the next request from it. (Nothing except the 'drainPipe' thread + -- should read from the pipe). Read with @'handleAsyncReq' p get Nothing@. + , mailboxQueues :: !(TVar (IntMap (TQueue (CorrelationId, LB.ByteString)))) + -- ^ Requests for a specific 'InboxId' that can be read using + -- @'handleAsyncReq' p get (Just <mailboxid>)@. + , asyncDrainTid :: !ThreadId + , asyncFreshId :: !(IORef Int) + } + +-- | Each 'Request' expects a 'Reply' with a matching 'CorrelationId'. +type CorrelationId = Int + +-- | We have a single type for requests and replies because both the host and +-- interpreter may send requests *and* replies on the write end *and* on recv +-- both on the read end. +-- +-- For instance: +-- 1. The host sends a RunTH request on its Host Write End (HWE) +-- 2. The interpreter sends a NewName TH request on its Interpreter Write End (IWE) +-- 3. The host sends a reply to the TH request on its HWE +-- 4. The interpreter sends the reply to the RunTH request on its IWE +-- +-- Additionally, we want to keep concurrent TH requests for independent RunTH +-- calls separated. Thus the interpreter requests additionally specify a +-- mailbox announced by RunTH: +-- 1. To interpreter: @Request _ Nothing (RunTH <mailid>)@ +-- 2. From interpreter: @Request _ (Just <mailid>) NewName@ +-- And the host will relate the <mailid> reverse requests to that RunTH run +-- exclusively. +data IddMsg = Request !CorrelationId !(Maybe InboxId) LB.ByteString + | Reply !CorrelationId (Either SerializableException LB.ByteString) + +instance Binary IddMsg where + put (Request i ii bs) = putWord8 0 >> put i >> put ii >> put bs + put (Reply i bs) = putWord8 1 >> put i >> put bs + get = do + b <- getWord8 + case b of + 0 -> Request <$> get <*> get <*> get + 1 -> Reply <$> get <*> get + _ -> fail $ "impossible: Binary IddMsg - " ++ show b + +newAsyncManager :: Pipe -> IO AsyncManager +newAsyncManager pipe = do + asyncFreshId <- newIORef 0 + pendingReply <- newTVarIO IntMap.empty + requestsQueue <- newTQueueIO + mailboxQueues <- newTVarIO IntMap.empty + + -- Fork thread to drain read end. + -- (cleaned up on 'closePipe') + asyncDrainTid <- forkIOWithUnmask (drainPipe pipe) + + let am = AsyncManager{..} + pure am + +-- | Drains the read end of the Pipe and match 'Reply'es against pending 'Request's. +-- +-- In pratice, we'll have both a thread draining the read end of the host's +-- 'Pipe' and a thread draining the read end of the interpreter's 'Pipe', since +-- both processes construct a 'Pipe' and send and receive messages +-- +-- Closes the Pipe read end when done reading +drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO () +drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings where + loop = do + readPipe p >>= \case + -- Receive a reply to a pending notification + Just (Reply uq bs) -> do + atomically $ do + m <- readTVar (pendingReply am) + case IntMap.lookup uq m of + Nothing -> + -- the req was dropped from pending bc there was an exception, and no + -- one's listening any more. the reply is ignored + pure () + Just wv -> do + writeTVar (pendingReply am) (IntMap.delete uq m) + -- signal matching request + putTMVar wv (bimap (toException . RemoteProcessException) id bs) + loop + -- Receive a request and queue it + Just (Request uq mbi bs) -> do + atomically $ case mbi of + Nothing -> + -- "Global" request + writeTQueue (requestsQueue am) (uq,bs) + Just ii -> do + -- "Specific mailbox" request + q <- getMailbox am ii + writeTQueue q (uq,bs) + loop + -- EOF on read handle + Nothing -> do + -- clean up pipe then exit loop + replyToPendings (toException PipeReadClosedException) + pure () + + replyToPendings e = atomically $ do + -- reqs are only added if pipe not closed; + -- thus we close and take all pending atomically. + writeTVar (pipeReadClosed p) True + pendings <- swapTVar (pendingReply am) IntMap.empty -- take pending + mapM_ (\p -> putTMVar p (Left e {-host exception-})) pendings + + am = pipeAsyncMngr p + +-- | An exception that can be thrown on the host process representing an +-- expection that happened on the remote one. +newtype RemoteProcessException = RemoteProcessException SerializableException deriving Show +instance Exception RemoteProcessException + +-- | Come up with a fresh id for 'CorrelationId' or 'InboxId' +freshId :: AsyncManager -> IO Int +freshId AsyncManager{asyncFreshId} = + atomicModifyIORef' asyncFreshId $ \i -> (i+1, i) + +-------------------------------------------------------------------------------- +-- * Consume `reply` exactly once +-------------------------------------------------------------------------------- + +-- | Every request should get exactly one reply. +data WriteReply a where + WriteReply :: (Either SomeException a -> IO ()) %1 -> WriteReply a + +-- | Write a reply exactly once (consuming the ability to write more replies) +writeReply :: WriteReply a %1 -> a -> IO () +writeReply (WriteReply r) = \x -> r (Right x) + +-- | Infix, linear, 'unIO' +(|#>) :: IO a %1 -> State# RealWorld -> (# State# RealWorld, a #) +(|#>) (IO fs) s = fs s + +-------------------------------------------------------------------------------- +-- * Serializable Exceptions +-------------------------------------------------------------------------------- + +-- SomeException can't be serialized because it contains dynamic +-- types. However, we do very limited things with the exceptions that +-- are thrown by interpreted computations: +-- +-- * We print them, e.g. "*** Exception: <something>" +-- * UserInterrupt has a special meaning +-- * In ghc -e, exitWith should exit with the appropriate exit code +-- +-- So all we need to do is distinguish UserInterrupt and ExitCode, and +-- all other exceptions can be represented by their 'show' string. +-- +data SerializableException + = EUserInterrupt + | EExitCode ExitCode + | EOtherException String + deriving (Generic, Show) + +toSerializableException :: SomeException -> SerializableException +toSerializableException ex + | Just UserInterrupt <- fromException ex = EUserInterrupt + | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) + | otherwise = EOtherException $ +#if MIN_VERSION_base(4,20,0) + -- Exception plus backtrace as seen in `displayExceptionWithInfo` + case displayExceptionContext (someExceptionContext ex) of + "" -> displayException (ex :: SomeException) + cx -> displayException (ex :: SomeException) ++ "\n\n" ++ cx +#else + show (ex :: SomeException) +#endif + +fromSerializableException :: SerializableException -> SomeException +fromSerializableException EUserInterrupt = toException UserInterrupt +fromSerializableException (EExitCode c) = toException c +fromSerializableException (EOtherException str) = toException (ErrorCall str) + +instance Binary ExitCode +instance Binary SerializableException ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase, CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server ( MessageHook , CustomMessageHandler @@ -15,6 +15,7 @@ import GHCi.Signals import GHCi.TH import GHCi.Message import Data.ByteString (ByteString) +import Data.IORef #if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B @@ -60,27 +61,29 @@ servWithCustom -> (forall a .IO a -> IO a) -> CustomMessageHandler -> IO () -servWithCustom verbose hook pipe restore customHandler = loop +servWithCustom verbose hook pipe restore customHandler = newIORef False >>= loop where - loop = do + loop doneRef = do when verbose $ trace "reading pipe..." - Msg msg <- readPipe pipe getMessage >>= hook - - discardCtrlC - - 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 - _other -> run msg >>= reply - - reply :: forall a. (Binary a, Show a) => a -> IO () - reply r = do - when verbose $ trace ("writing pipe: " ++ show r) - writePipe pipe (put r) - loop + handleRemoteCall pipe hook $ \(msg :: Message a) -> do + + discardCtrlC + + when verbose $ trace ("msg: " ++ (show msg)) + case msg of + CustomMessage tag payload -> handleCustom tag payload + Shutdown -> writeIORef doneRef True >> reply () + -- TODO: These two should probably be done off the main thread + RunTH ii st q ty loc -> wrapRunTH ii $ runTH pipe ii st q ty loc + RunModFinalizers ii st qrefs -> wrapRunTH ii $ runModFinalizerRefs pipe ii st qrefs + _other -> run msg >>= reply + + -- closePipe here will wait until every active pipeWrite pipe exits, but + -- they should never block for long, as the host process is either reading + -- or has called pipeCloseRead. + isDone <- readIORef doneRef + if isDone then closePipe pipe + else loop doneRef handleCustom tag payload = do mresp <- customHandler tag payload @@ -89,17 +92,22 @@ servWithCustom verbose hook pipe restore customHandler = loop Nothing -> error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + reply :: forall a. Show a => a -> IO a + reply r = do + when verbose $ trace ("writing pipe: " ++ show r) + return r -- the result of the handler gets sent + -- 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 -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. - wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () - wrapRunTH io = do + wrapRunTH :: forall a. (Binary a, Show a) => InboxId -> IO a -> IO (QResult a) + wrapRunTH ii io = do when verbose $ trace "wrapRunTH..." r <- try io when verbose $ trace "wrapRunTH done." when verbose $ trace "writing RunTHDone." - writePipe pipe (putTHMessage RunTHDone) + remoteTHCall pipe ii RunTHDone case r of Left e | Just (GHCiQException _ err) <- fromException e -> do @@ -179,7 +187,7 @@ defaultServerWithCustom customHandler = do #if defined(wasm32_HOST_ARCH) -- See Note [wasm ghci signal handlers] for details installSignalHandlers $ js_register_signal_handler cb_sig - pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) + pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) (pure ()) (pure ()) #else when verbose $ printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh) ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -115,8 +115,8 @@ import qualified GHC.Boot.TH.Monad as TH import Unsafe.Coerce -- | Create a new instance of 'QState' -initQState :: Pipe -> QState -initQState p = QState M.empty Nothing p +initQState :: Pipe -> InboxId -> QState +initQState p ii = QState M.empty Nothing ii p -- | The monad in which we run TH computations on the server newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a } @@ -156,7 +156,7 @@ noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0) ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a ghcCmd m = GHCiQ $ \sRef -> do s <- readIORef sRef - r <- remoteTHCall (qsPipe s) m + r <- remoteTHCall (qsPipe s) (qsInboxId s) m case r of THException str -> throwIO (GHCiQException s str) THComplete res -> return res @@ -189,9 +189,9 @@ metaHandlersGHCiQ runInIO = TH.MetaHandlers { -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do s <- readIORef sRef - remoteTHCall (qsPipe s) StartRecover + remoteTHCall (qsPipe s) (qsInboxId s) StartRecover e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef - remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + remoteTHCall (qsPipe s) (qsInboxId s) (EndRecover (isLeft e)) case e of Left GHCiQException{} -> runGHCiQ (runQinGHCiQ h) sRef @@ -233,26 +233,28 @@ metaHandlersGHCiQ runInIO = TH.MetaHandlers { -- a new IORef QState, and return a RemoteRef to it. startTH :: IO (RemoteRef (IORef QState)) startTH = do - r <- newIORef (initQState (error "startTH: no pipe")) + r <- newIORef (initQState (error "startTH: no pipe") (error "startTH: no inbox id")) mkRemoteRef r -- | Runs the mod finalizers. -- -- The references must be created on the caller process. -runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState) +runModFinalizerRefs :: Pipe -> InboxId + -> RemoteRef (IORef QState) -> [RemoteRef (TH.Q ())] -> IO () -runModFinalizerRefs pipe rstate qrefs = do +runModFinalizerRefs pipe ii rstate qrefs = do qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - qstate' <- newIORef $ qstate { qsPipe = pipe } + qstate' <- newIORef $ qstate { qsInboxId = ii, qsPipe = pipe } _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message runTH :: Pipe + -> InboxId -> RemoteRef (IORef QState) -- ^ The TH state, created by 'startTH' -> HValueRef @@ -264,13 +266,13 @@ runTH -> IO ByteString -- ^ Returns an (encoded) result that depends on the THResultType -runTH pipe rstate rhv ty mb_loc = do +runTH pipe ii rstate rhv ty mb_loc = do hv <- localRef rhv case ty of - THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp) - THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat) - THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type) - THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec]) + THExp -> runTHQ pipe ii rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp) + THPat -> runTHQ pipe ii rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat) + THType -> runTHQ pipe ii rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type) + THDec -> runTHQ pipe ii rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec]) THAnnWrapper -> do hv <- unsafeCoerce <$> localRef rhv case hv :: AnnotationWrapper of @@ -279,10 +281,10 @@ runTH pipe rstate rhv ty mb_loc = do -- | Run a Q computation. runTHQ - :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a + :: Binary a => Pipe -> InboxId -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a -> IO ByteString -runTHQ pipe rstate mb_loc ghciq = do +runTHQ pipe ii rstate mb_loc ghciq = do qstateref <- localRef rstate - modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) + modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsInboxId = ii, qsPipe = pipe }) r <- runGHCiQ (runQinGHCiQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -76,6 +76,7 @@ library exposed-modules: GHCi.BreakArray GHCi.Message + GHCi.Message.Async GHCi.ResolvedBCO GHCi.RemoteTypes GHCi.FFI @@ -95,7 +96,8 @@ library filepath >= 1.4 && < 1.6, ghc-boot == @ProjectVersionMunged@, ghc-heap >= 9.10.1 && <=@ProjectVersionMunged@, - transformers >= 0.5 && < 0.7 + transformers >= 0.5 && < 0.7, + stm >= 2.4 && < 2.6 if flag(bootstrap) build-depends: ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -12,6 +12,7 @@ import GHCi.Message , mkPipeFromHandles , remoteCall , Pipe + , closePipe ) import GHCi.Server ( CustomMessageHandler @@ -153,14 +154,13 @@ customMessage pipe c = do runClient :: Int -> IO () runClient input = do serverExe <- getExecutablePath - withServer serverExe $ \hFromServer hToServer -> do - pipe <- mkPipeFromHandles hFromServer hToServer + withServer serverExe $ \pipe -> do 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 :: FilePath -> (Pipe -> IO a) -> IO a withServer serverExe action = do (ghcRead, serverWrite) <- createPipe (serverRead, ghcWrite) <- createPipe @@ -171,13 +171,14 @@ withServer serverExe action = do , std_out = Inherit , std_err = Inherit } - bracket (mkHandles ghcRead ghcWrite) - (\(hFromServer, hToServer) -> do + bracket (mkHandles ghcRead ghcWrite >>= \hds -> (hds,) <$> uncurry mkPipeFromHandles hds) + (\((hFromServer, hToServer), pipe) -> do + closePipe pipe hClose hFromServer hClose hToServer terminateProcess ph void (waitForProcess ph)) - (\(hFromServer, hToServer) -> action hFromServer hToServer) + (\(_, pipe) -> action pipe) where mkHandles r w = do hR <- fdToHandle r View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2c42e7a8e8584caab528cfce1122e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2c42e7a8e8584caab528cfce1122e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/async-rpc] 2 commits: we may still reply if we had some queued msgs read already
by Rodrigo Mesquita (＠alt-romes) 15 Oct '26

15 Oct '26

Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 86f0d70c by Rodrigo Mesquita at 2026-10-15T11:33:44+01:00 we may still reply if we had some queued msgs read already - - - - - c2c42e7a by Andrea Vezzosi at 2026-10-15T11:42:27+01:00 interp: close Handles when done with Pipe Ensures we close the pipe handles (if created using 'mkPipeFromHandles') on `closePipe`, and do `closePipe` on `Shutdown`. The thread draining the read end always `'finally'` closes the read end. And `closePipe` kills the draining thread and closes the write end. When `remoteAsyncReq`, we throw PipeReadClosedException if the pipe read is closed, since we wouldn't be able to receive the reply. It's fine for the drain thread not to close the write end, even if it dies without `closePipe` (which does close the write end), because: - requests pending a reply will get PipeClosedException (we'll not be able to read any further "real" reply) - new calls to `remoteAsyncReq` will throw PipeReadClosedException - pending pipe writes, in response to an already read request, might still succeed And the clean up code should call close pipe to ensure the write end is closed as well. So, if the drain thread dies naturally and the read end is closed, may still be attempted to be used, but it will throw accordingly. The user likely wants to catch this to close the write end as well. - - - - - 3 changed files: - compiler/GHC/Runtime/Interpreter.hs - libraries/ghci/GHCi/Message/Async.hs - libraries/ghci/GHCi/Server.hs Changes: ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -654,6 +654,8 @@ stopInterp interp = case interpInstance interp of if isJust ex then pure () else sendMessage i Shutdown + -- We asked the server to shutdown, so we will also shutdown any communication. + closePipe (interpPipe (instProcess i)) pure InterpPending -- ----------------------------------------------------------------------------- ===================================== libraries/ghci/GHCi/Message/Async.hs ===================================== @@ -70,8 +70,13 @@ data Pipe = Pipe , pipeLeftovers :: !(IORef (Maybe ByteString)) , pipeLock :: !(MVar ()) -- ^ Lock to prevent concurrent writes to the stream , pipeAsyncMngr :: !AsyncManager - , pipeIsClosed :: !(TVar Bool) - -- ^ After the pipe is closed, requests can no longer be received nor sent + , pipeCloseRead :: !(IO ()) + -- ^ closes read end of the pipe + , pipeCloseWrite :: !(IO ()) + -- ^ closes write end of the pipe + , pipeReadClosed :: !(TVar Bool) + -- ^ After the pipe is closed, messages can no longer be received from the + -- other end, but the 'AsyncManager' queues might not be empty yet. } -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. @@ -82,43 +87,49 @@ mkPipeFromHandles pipeRead pipeWrite = do putAll b = do B.hPutBuilder pipeWrite b hFlush pipeWrite - mkPipeFromContinuations getSome putAll + mkPipeFromContinuations getSome putAll (hClose pipeRead) (hClose pipeWrite) -- | Make a 'Pipe' from a reader function and a writer function. --- The pipe should be closed with 'closePipe'. -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe -mkPipeFromContinuations getSome putAll = mdo +-- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'. +mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) + -> IO () + -- ^ pipeCloseRead + -> IO () + -- ^ pipeCloseWrite + -> IO Pipe +mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo pipeLeftovers <- newIORef Nothing pipeLock <- newMVar () - pipeIsClosed <- newTVarIO False + pipeReadClosed <- newTVarIO False mdo pipeAsyncMngr <- newAsyncManager p let p = Pipe { .. } pure p --- | Cleanly close our end of the Pipe, terminating the async manager's --- drain-read-end thread. Calling 'closePipe' on an already closed pipe is a no-op. +-- | Cleanly close our ends of the Pipe, terminating the async manager's +-- drain-read-end thread. Also calls 'pipeCloseRead' and 'pipeCloseWrite', in that order. -- --- If the pipe was created using 'mkPipeFromHandles', the handles must only by --- closed after calling 'closePipe'. +-- If the pipe was created using 'mkPipeFromHandles', the handles are also closed. -- -- The requests we've sent that are pending are all canceled with -- 'PipeClosedException' by ourselves. -- --- The remote process does not necessarily detect that this end of the pipe was --- closed, but it must handle cleanly and clean up after exceptions caused from --- it such as a handle being closed. +-- No special notification is sent to the remote process, a message to that +-- effect should be sent ahead of time if one is needed (see 'Shutdown'). closePipe :: Pipe -> IO () closePipe Pipe{..} = do - isAlreadyClosed <- atomically $ swapTVar pipeIsClosed True + readAlreadyClosed <- atomically $ swapTVar pipeReadClosed True - unless isAlreadyClosed $ do + -- this triggers pipeCloseRead + unless readAlreadyClosed $ do -- releases handle lock taken by reading, and cleans up by replying to every -- pending request with 'PipeClosedException'. throwTo (asyncDrainTid pipeAsyncMngr) PipeClosedException + pipeCloseWrite + -- | We've closed the pipe on our end and we terminate all pending requests with this. data PipeClosedException = PipeClosedException deriving Show instance Exception PipeClosedException @@ -186,7 +197,8 @@ remoteAsyncReq pipe msg ii = do wv <- newEmptyTMVarIO isClosed <- atomically $ do - isClosed <- readTVar (pipeIsClosed pipe) + isClosed <- readTVar (pipeReadClosed pipe) + -- don't send the req if we won't get a reply. if isClosed then pure True else do @@ -223,15 +235,17 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do -- Block waiting for request mbreq <- atomically $ do - isClosed <- readTVar (pipeIsClosed pipe) - if isClosed - then return Nothing - else Just <$> case mii of - Nothing -> readTQueue $ requestsQueue am - Just ii -> readTQueue =<< getMailbox am ii + isClosed <- readTVar (pipeReadClosed pipe) + taken <- case mii of + Nothing -> tryReadTQueue $ requestsQueue am + Just ii -> tryReadTQueue =<< getMailbox am ii + case taken of + Just req -> pure (Just req) + Nothing | isClosed -> pure Nothing -- empty and closed + | otherwise -> retry -- wait for msg case mbreq of - Nothing -> throwIO PipeClosedException + Nothing -> throwIO PipeClosedException -- can't expect reqs Just (uq, bs) -> do let reply p = do writePipe pipe (Reply uq (bimap toSerializableException runPut p)) @@ -368,8 +382,10 @@ newAsyncManager pipe = do -- In pratice, we'll have both a thread draining the read end of the host's -- 'Pipe' and a thread draining the read end of the interpreter's 'Pipe', since -- both processes construct a 'Pipe' and send and receive messages +-- +-- Closes the Pipe read end when done reading drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO () -drainPipe p unmask = catch (unmask loop) replyToPendings where +drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings where loop = do readPipe p >>= \case -- Receive a reply to a pending notification @@ -404,7 +420,9 @@ drainPipe p unmask = catch (unmask loop) replyToPendings where pure () replyToPendings e = atomically $ do - writeTVar (pipeIsClosed p) True + -- reqs are only added if pipe not closed; + -- thus we close and take all pending atomically. + writeTVar (pipeReadClosed p) True pendings <- swapTVar (pendingReply am) IntMap.empty -- take pending mapM_ (\p -> putTMVar p (Left e {-host exception-})) pendings ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -78,6 +78,9 @@ servWithCustom verbose hook pipe restore customHandler = newIORef False >>= loop RunModFinalizers ii st qrefs -> wrapRunTH ii $ runModFinalizerRefs pipe ii st qrefs _other -> run msg >>= reply + -- closePipe here will wait until every active pipeWrite pipe exits, but + -- they should never block for long, as the host process is either reading + -- or has called pipeCloseRead. isDone <- readIORef doneRef if isDone then closePipe pipe else loop doneRef @@ -184,7 +187,7 @@ defaultServerWithCustom customHandler = do #if defined(wasm32_HOST_ARCH) -- See Note [wasm ghci signal handlers] for details installSignalHandlers $ js_register_signal_handler cb_sig - pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) + pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) (pure ()) (pure ()) #else when verbose $ printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d5fc67e1bbc53107ae639eaf613c2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d5fc67e1bbc53107ae639eaf613c2… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T15963-report-timeouts] 94 commits: rts: fix ctoi_tuple_spill_words getting out of sync
by Simon Jakobi (＠sjakobi) 15 Oct '26

15 Oct '26

Simon Jakobi pushed to branch wip/sjakobi/T15963-report-timeouts at Glasgow Haskell Compiler / GHC Commits: 192be0b6 by Luite Stegeman at 2026-09-07T19:43:36-04:00 rts: fix ctoi_tuple_spill_words getting out of sync Fix a few places that were not updating ctoi_tuple_spill_words correctly, leading to corruption/crashes when dealing with large unboxed tuples in bytecode: - captureContinuationAndAbort - findRetryFrameHelper/findAtomicallyFrameHelper - interpretBCO bci_BRK_FUN fixes #27633 - - - - - 604eb43c by Simon Jakobi at 2026-09-07T19:44:15-04:00 Hadrian: don't capture the testsuite driver's output (#27780) a6061455d54 switched the Testsuite RunTest case from Shake's cmd to the cmd' wrapper. cmd' always captures stdout and stderr, and since the caller asks for Exit, it returns without dumping what it captured. As a result the testsuite output no longer appears in CI job logs: failures, performance metrics and the summary were lost with the job. Use cmdExe, the uncaptured cmd, as the other plain-cmd sites in that commit do. Fixes #27780. Assisted-by: Claude Fable 5.1 - - - - - 06eee015 by Luite Stegeman at 2026-09-08T06:03:06+02:00 rts: Fix missing memory barrier in eval_thunk_selector (#27477) unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the indirectee, leading to segfaults and corruption during GC on weakly-ordered architectures. Fixes #27477 - - - - - f8b2bd8f by Alan Zimmerman at 2026-09-08T09:39:12-04:00 EPA Fix HsCmdDo exact print with comments Exact printing of HsCmdDo was ignoring the location for the do statements, and this is an annotation that can have comments in it. Update it so we print the statements as a unit, including any comments. Also add the result of auditing that we capture comments in all needed places, noting that the remaining Anno SrcSpan instances are benign. - - - - - 430967ab by Duncan Coutts at 2026-09-09T11:07:01+01:00 Reorder cmm decls in HeapStackCheck for a better logical grouping And put more section headers in to deliniate the groups. We're about to add more here, so better to organise it first. - - - - - 344080fd by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add raisePrimIOException and add it to RTS<->ghc-internal API The raisePrimIOException is a new helper function that I/O primops will use to help them report I/O errors. This is implemented in Haskell (since that's a lot easier), but has a calling convention that is easy(ish) to use from Cmm in the I/O primops. So we add it to the RTS API struct, and since we'll use it from Cmm we also need a field accessor macro for cmm (in deriveConstants). See the Note about how we cannot have nice things due to async exceptions and thunks preventing us from using catch. - - - - - cfdb3399 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add new blocking functions for I/O primops See the Note [Thread blocking for new I/O primops], and the Note [Calling convention for raisePrimIOException]. The point is, it will allow us to report synchronous exceptions from I/O primops, and do so much more flexibly. Previously the I/O managers could only report async exceptions and only nullary exceptions. This was OK historically, but no good as we add more I/O managers and expand the range of I/O operations we support. - - - - - f09c09d8 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Change the encoding of results from the I/O manager to I/O primops Previously we just had async continue or heap overflow. We now extend what we can report with synchronous success, and synchronous failure with an errno. See Note [Encoding of result of I/O manager operations] We don't use these two new cases yet, but we will. In particular an epoll I/O manager needs to be able to report synchronous success or failure for waitRead#/waitWrite#. - - - - - 30f074d9 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch waitRead/Write# to use new blocking return frames and update the I/O managers to set the result before resuming the blocked threads. This makes it possible for I/O managers to report synchronous exceptions from the I/O primops, but that will be done in a subsequent commit. - - - - - a8786ced by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch Poll and Select I/O managers to report sync exceptions rather than using raiseAsync with blockedOnBadFD_closure. This uses the new mechanism in the blocking frame return code to report synchronous exceptions. - - - - - 7a9df79a by Duncan Coutts at 2026-09-09T11:07:01+01:00 Remove now-unused blockedOnBadFD It was previously thrown by the select and poll I/O managers, but now they use raisePrimIOException (with an EBADF errno). - - - - - 6b0424e3 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Improve the docs for delay# waitRead# and waitWrite# Document that the waitRead/Write# can throw exceptions (this was true before too), and that all of them are async exception cancellation points. - - - - - afeb2c30 by Duncan Coutts at 2026-09-09T20:08:58-04:00 Enable printf warnings for trace functions and fix resulting warnings Most of the existing printf-style functions are annotated with attributes to enable gcc/clang warnings for the printf format string, but several trace functions in Trace.h were missing this annotation. Enable them, and fix the resulting warnings. - - - - - 9a442c93 by Alan Zimmerman at 2026-09-09T20:09:36-04:00 EPA: Exact print ConDeclGADT without custom enterAnn !16321 brought in explicit capture of parens in a ConDeclGADT. The ExactPrint update introduced a modification of the fundamental function in exact printing, `enterAnn`, by splitting it into a version allowing injection of functionality normally handled by the ExactPrint class methods. This commit refactors that code, to restore the prior `enterAnn` version, by following the convention in ExactPrint of introducing a helper data structure with its own `ExactPrint` instance to achieve the same effect. - - - - - 4e9297ea by Simon Jakobi at 2026-09-11T08:32:45-04:00 ci: Actually pass --ignore-perf-failures to the testsuite driver 684c0018d9 changed the IGNORE_PERF_FAILURES handling to append to RUNTEST_ARGS with bash array syntax, but the three use sites still expand RUNTEST_ARGS as a scalar, which yields only the first array element. The appended flag was therefore dropped in every job, so perf improvements kept failing Marge Bot batches and master pipelines, contrary to #19562. Append as a string instead, matching the existing --force-colors append in test_hadrian. Fixes #27563. Assisted-by: Claude Fable 5.1 - - - - - 4f78dfdf by Simon Jakobi at 2026-09-11T08:33:24-04:00 testsuite: Give T26537 a 1.5x compile timeout Its -fregs-graph compile step tends to time out in unoptimized builds (#27188, #27776). Assisted-by: Claude Fable 5.1 - - - - - 130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00 EPA: Remove ListBanana / ListParens from AnnListBrackets This is a step towards making AnnList only represent lists of items which can have either braces or layout. - - - - - a9827d13 by Simon Jakobi at 2026-09-11T18:53:32-04:00 Reject ~, UNPACK and multiplicity annotations on type data fields Only `!` was rejected so far. `~`, UNPACK and multiplicity annotations were silently accepted. None of them make sense at the type level, so restriction (R3) of Note [Type data declarations] now covers all of them. Fixes #27732. Assisted-by: Claude Fable 5.1 - - - - - c71d5e23 by Alan Zimmerman at 2026-09-11T18:54:11-04:00 EPA: Add a Note for the exact print main loop - - - - - 7a108e43 by Simon Jakobi at 2026-09-12T18:35:59-04:00 FastString: Drop mkFastStringWith's constructor callback All three callers passed the same callback, a partial application of mkNewFastStringShortByteString to the string being interned. That partial application is allocated as a closure before the table lookup, on the common hit path too, although the callback is needed only after a miss. Drop the parameter and call mkNewFastStringShortByteString directly after a miss. Since nothing is passed "with" anymore, rename the function to internSB. Suggested by Simon PJ in #27528: https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031 Assisted-by: Claude Fable 5 - - - - - 82c73b22 by Alan Zimmerman at 2026-09-12T18:36:38-04:00 EPA: More targeted HsDo exact print annotation HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of these are in a layout context (DoExpr, MDoExpr), others are not (ListComp, MonadComp). We are moving towards using AnnList only in layout contexts, so we switch the HsDo TTG annotation from holding an AnnList for this, to holding Either (EpToken "[", EpToken "]") AnnList This also allows us to trim down AnnListBrackets to only have braces or None, thereby opening the door for unification with the existing layout context data type EpLayout. - - - - - 749d2448 by Luite Stegeman at 2026-09-15T14:07:01-04:00 rts: handle large CONSTR closures in compacting GC The function update_fwd_large in the compacting GC could run into an unexpected object with the following error: internal error: update_fwd_large: unknown/strange object 1 Closure type 1 is CONSTR. This patch adds cases for CONSTR and CONSTR_NOCAF. This is the same problem as #27434 (large AP closures, fixed by cca0d58963), which missed this case. Fixes #27649 - - - - - 177d6155 by Luite Stegeman at 2026-09-15T14:07:02-04:00 testsuite: fix T27434 test with compacting GC Ensure that the interpreter is actually run with the compacting GC - - - - - 5796aa63 by Luite Stegeman at 2026-09-15T14:07:49-04:00 rts: initialise the stack frame header for mask_frame and apply_mask_frame We must leave the stack in consistent state before jumping to mask_frame or apply_mask_frame because they may result. Failing to do so could lead to a crash if there were waiting exceptions. Fixes #27651 - - - - - 2486cc92 by Simon Peyton Jones at 2026-09-15T14:08:36-04:00 Re-introduce the "weird SpecDict" case In this commit commit f80375dd4945350a1d784e436975b48b9c736eaf Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Sun Jun 29 15:26:58 2025 +0100 Refactor of Specialise.hs I removed a test for a dictionary with unbound type variables. This turned out to be wrong; see #27629. So this MR re-introduces it. - - - - - 8e09a46f by Duncan Coutts at 2026-09-15T20:11:35-04:00 Refactor (and rename) removeFromQueues, to simplify I/O managers Rename it to unblockAndAppendToRunQueue which better reflects what it is intended to do. The post-condition for unblockAndAppendToRunQueue is that the TSO is on the run queue or it is in the process of migrating to another cap. Previously it achieved that by always directly adding the TSO to the run queue itself. But this actually made things more complicated for the I/O managers, because it meant they needed a separate code path for notifying for cancellation compared to notifying for completion. The general notification code would always add the TSO to the run queue itself. So the improvement is to allow different cases in unblockAndAppendToRunQueue to achieve the same outcome in different ways: either directly adding to the run queue or calling helper functions that do so themselves. This then allows the new I/O managers to share code between the sync and async cancellation, and to reuse their notifyIOCompletion helpers for cancellation. This avoids a source of bugs where the completion path may be updated but the cancellation path may be forgotten, or similarly in future for sync/async operations. Update all the existing in-RTS I/O managers, and the posix timeout code. - - - - - d668782c by Duncan Coutts at 2026-09-15T20:11:35-04:00 Document that awaitCompletedTimeoutsOrIO expects an empty run queue This was true before but implicit and not relied on much. It's better to be explicit, and allow things to depend on it. - - - - - 11d938bb by Duncan Coutts at 2026-09-15T20:11:35-04:00 Store the I/O opcode and fd in the StgAsyncIOOp This will be useful in several I/O managers and it is handy for logging and debugging. It also doesn't increase the size of the StgAsyncIOOp structure. There was enough spare padding space already. Update the poll I/O manager to set the new fields. Add a helper function to convert the enum IOReadOrWrite into the enum IOOpCode. Also change IOReadOrWrite to be an enum without a typedef, for consistency with other enumerations in IOManager.h - - - - - bfa87882 by Duncan Coutts at 2026-09-15T20:11:36-04:00 Add a new I/O manager based on select() Yes, this is the second such I/O manager, but it is a modern re-implementation based on the new in-RTS I/O manager infrastructure. So it is cleaner and faster than the old select I/O manager. Why do we need another I/O manager based on select? Why isn't the poll() one good enough as a baseline portable unix I/O manager? Because macOS. Apple Inc. is why we cannot have nice things. The man page for poll on macOS documents the fact that it does not work. At least, it does not work for all files. Specifically, it does not work for device files. Whereas macOS select() does work for device files. Aaaaarg! We _do_ want to deprecate and remove the old select I/O manager, but due to macOS we cannot do that until we have a replacement. This is that replacement. Until of course a nice new k-queue I/O manager arrives, which could become the new default for macOS and FreeBSD. Interestingly, this select I/O manager is actually faster than the poll one, on Linix, in some circumstances: specifically when many Haskell threads are waiting on the same fd. The poll I/O manager does O(n) work for n threads waiting on I/O, whereas the select one does O(fds) work for the number of fds that threads are waiting on. Usually this is 1:1, so it's not noticable, but one can concoct extreme benchmarks to show the difference. - - - - - 8e9de15a by Duncan Coutts at 2026-09-15T20:11:36-04:00 Minor updates in the poll I/O manager to keep in sync with select This keeps it in sync with select one. The changes are based on code review while implementing the new select I/O manager. The two I/O managers are so similar in structure that it makes sense to try to minimise the diff between them. This should aid understanding, and fixes to both in future. - - - - - 222668bb by Duncan Coutts at 2026-09-15T20:11:36-04:00 Document the new select I/O manager in the user guide in the RTS section about I/O managers. And add a changelog entry. - - - - - 0f48735b by Cheng Shao at 2026-09-15T20:12:23-04:00 Revert "wasm: workaround WebKit bug in dyld" This reverts commit c9b8465c2c338176fcab9d197e9d31f4aee11f68. The underlying webkit bug has been fixed in https://commits.webkit.org/314219@main. Closes #27564. - - - - - 809294f1 by Luite Stegeman at 2026-09-15T20:13:08-04:00 rts: make stg_threadLabelzh return a valid pointer for unlabeled threads. This fixes a segfault in the GC caused by stg_threadLabelzh returning a 0 pointer in a GC pointer field. stg_threadLabelzh returns a tuple of type (# Int#, ByteArray# #). If a thread has no label, the second field is unused. We must still return a valid heap object pointer. Instead of returning 0, we now return stg_DEAD_SLOT_closure. fixes #27618 - - - - - e2d57026 by Luite Stegeman at 2026-09-15T20:13:54-04:00 JS: fix selector thunk handling fix a bug where entering a selector thunk could lead to a crash if the selected field was still a thunk. fixes #27788 - - - - - 1b4a622f by sheaf at 2026-09-17T02:39:13-04:00 Improvements to type/data family handling This commit makes several improvements to the treatment of type and data families in GHC: - We consistently use "type family" instead of "type synonym family" to avoid a confusion with type synonyms. For example: - OpenSynFamilyTyCon ==> OpenTypeFamilyTyCon - ClosedSynFamilyTyCon => ClosedTypeFamilyTyCon - Various functions that were specific to data families have been renamed to make this clear. For example: - tyConFamInst_maybe ==> tyConDataFamInst_maybe - isFamInstTyCon ==> isDataFamInstTyCon - 'FamTyConFlav' has been refactored so that all closed type families share a single 'ClosedTypeFamilyTyCon' constructor. The corresponding 'IfaceFamTyConFlav' type was updated similarly. This is then used to tidy up the implementation of GHC.Core.FamInstEnv.reduceTyFamApp_maybe. - - - - - c5aa9098 by sheaf at 2026-09-17T02:39:13-04:00 Small refactor of lookupFamInstEnv This commit reworks the code for looking up family instances in GHC.Core.FamInstEnv, reducing duplication a little bit. No change in behaviour. - - - - - a3ad4588 by sheaf at 2026-09-17T02:39:14-04:00 Use a type family for boxing unboxed types This commit overhauls the way in which unboxed types are boxed, as per the updated Note [Boxing constructors] in GHC.Builtin.WiredIn.Types.Box. The main change is to allow boxing to be parametrised by representation, e.g. making 'Box ty' a valid type. We achieve this by implementing 'Box' using a closed type family: newtype Box (a :: TYPE r) = Box (BoxTF r) type BoxTF :: RuntimeRep -> Type type family BoxTF r where BoxTF IntRep = BoxInt BoxTF Int8Rep = BoxInt8 BoxTF WordRep = BoxWord BoxTF LiftedRep = Any @Type BoxTF (TupleRep [r1, r2]) = (BoxTF r1, BoxTF r2) ... BoxTF (SumRep rs) = BoxSum rs This new design solves the following problems: - It allows boxing a type whose 'RuntimeRep' has not yet been determined (e.g. because we only learn the 'RuntimeRep' after constraint solving). That is, 'Box @r a' is a perfectly valid type even if 'r' is an unfilled metavariable. This is a requirement to fix #25065 (in which we need to box a type whose 'RuntimeRep' is only filled in during constraint solving). - It handles boxing of unboxed tuples and unboxed sums, via recursive boxing. See Note [Boxing TupleRep and SumRep] in GHC.Builtin.WiredIn.Types.Box. 'Box', 'BoxTF' and all of the boxing data constructors are defined in a new 'ghc-internal' module, 'GHC.Internal.Box'. This module contains nothing but wired-in declarations, and GHC never loads its interface on account of a wired-in thing (GHC.Builtin.Modules.isWiredInOnlyModule); see Note [Loading instances for wired-in things] in GHC.Iface.Load. The individual boxing data constructors are deliberately left as an internal implementation detail, and not exported. The intended API is via the two new magic 'Id's: box :: forall {r} (a :: TYPE r). a -> Box a unbox :: forall {r} (a :: TYPE r). Box a -> a exported from 'GHC.PrimOps' (in 'ghc-experimental'). The old boxing data types (IntBox, WordBox, FloatBox, DoubleBox, DictBox) are no longer exported from base (CLC proposal #421). We use this new design to consistently desugar: - parallel comprehensions (GHC.HsToCore.ListComp.{deListComp,dsMcStmt}) - then/group/using statements (GHC.HsToCore.ListComp.{dsTransStmt,dsMcStmt}) - recursive do blocks (mdo/rec) (GHC.HsToCore.Expr.dsDo) - arrows (GHC.HsToCore.Arrows) by consistently using 'box'/'unbox' to deal with unboxed types being put into big tuples. We also adapt 'GHC.Tc.Gen.Match.{tcMcStmt,tcDoStmt}' to create fresh /representation-polymorphic/ type variables for the binders that we are going to put into a big tuple (previously, GHC only allowed lifted types in that position). These desugaring of box and unbox is explained in Note [Desugaring box & unbox] in GHC.Core.Make.Box. Roughly speaking, the desugaring looks like: box @r @ty e ==> K e unbox @r @ty e ==> case e of K x -> x where 'K' is the boxing data constructor at RuntimeRep 'r'. It's slightly more complicated than that in practice: we first need to insert a cast (see Note [The canonical type of a RuntimeRep]) using the new 'CanonicalProv' 'UnivCoProvenance', and unboxed tuples/sums need recursive logic explained in Note [box/unbox for unboxed tuples and sums], including a specific 'BoxSum' datatypes for unboxed sum (which also needed a wired-in type-level list indexing type family (!!)). The desugaring happens in two ways: - Occurrences of 'box'/'unbox' emitted by the typechecker are eliminated in the 'ds_app_var' case of GHC.HsToCore.Expr. - Other code that needs to box/unbox emits the appropriate code inline. This includes the big tuple machinery of GHC.Core.Make used by the desugarer (GHC.HsToCore.{Utils,Binds,Arrows,ListComp}) as well as the float-out pass (GHC.Core.Opt.SetLevels). Core Lint checks that no occurrence of 'box'/'unbox' survives desugaring. On the way, we overhaul the litany of big tuple functions by introducing data BigTupleLayout = BoxedElements | BareElements to distinguish the two kinds of "big tuples" that GHC routinely deals with; for example 'mkBigCoreVarTupSolo' becomes 'mkBigCoreVarTup BareElements'. All of this code is moved to the new module GHC.Core.Make.BigTuple. Fixes #20864 #22336 #22473 #25065 #27331 ------------------------- Metric Decrease: T9872a ------------------------- - - - - - 4cf7628a by Evgeny Malyshev at 2026-09-17T02:39:56-04:00 Fix the CompactionFailed documentation link to compact The old Haddock reference links into base instead of ghc-compact. Use an explicit URL because ghc-compact depends on base, not vice versa. Fixes #27558 Assisted-By: OpenAI Codex - - - - - 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - 53eead15 by Wolfgang Jeltsch at 2026-09-24T20:12:03-04:00 Correct the documentation of `explicitUnits` Resolves #27787. - - - - - 35bf6f4b by Simon Jakobi at 2026-09-24T20:12:49-04:00 Remove stale specHeader bullet from Note [Don't make fillers for constraint types] The Note said that Specialise.specHeader also calls mkAbsentFiller. abfc224a27c removed that call: the specialiser no longer drops dead arguments at all, see Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise. Assisted-by: Claude Fable 5.1 - - - - - 1abef1ef by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the `mhu-closure` makefile - - - - - a79a68ea by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Make `ghci-multi` hide all unneeded packages - - - - - d6e72450 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the definition of the home unit closure property - - - - - c9a2766d by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - fa96acf8 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Remove erroneous GHC flag in `hadrian-multi` The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its purpose was to permit incomplete record selectors, but because of the illegal combination of `-Werror=` and `-Wno-error` it was ignored, without any negative consequences. - - - - - 9f48a5b9 by Alan Zimmerman at 2026-09-25T17:02:50-04:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - c406135c by Andreas Klebinger at 2026-10-01T06:57:28-04:00 RTS: Update flag parsing/handling: Using 0 as argument to any of these flags now resets the flags setting to default: - ``-n0`` disables nursery chunking. - ``-K0`` (or a bare ``-K``) removes the stack size limit. - ``-M0`` removes the heap size limit. - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. - ``-AL0`` makes the large object allocation limit follow ``-A`` again. GC Generations are now limited to 64. -n larger than -A now emits a warning and disables chunking. Fixes #27830 #27829 - - - - - 984ee82b by Andreas Klebinger at 2026-10-01T06:58:10-04:00 Fix MultiLayerModules timeout multiplier. We accidentally used the compile multiplier for ghci commands which use the run timeout setting to set the timeout. Fixes #26263 and #27796. - - - - - 50a9cf26 by Andreas Klebinger at 2026-10-01T06:58:10-04:00 testsuite: Include runtime in JUnit report. - - - - - e358619f by Alan Zimmerman at 2026-10-01T06:59:01-04:00 EPA: Use EpaLocation in EpVirtualBraces Haddock processing uses EpLayout.EpVirtualBraces to record the current layout column, for allocating haddock comments correctly. For exact printing, we need the line as well as the col, so we know how many lines to skip when the indented code block starts. This commit updates EpLayout.EpVirtualBraces so that it carries an EpaLocation instead of just the Int column, to allow it to be used for both purposes. It is a simple mechanical change, with no other impact, but it allows us to use EpLayout instead of AnnListLayout in AnnList, in the next commit in this series. - - - - - 1d2a26ee by Andrew Lelechenko at 2026-10-01T20:22:04-04:00 Remove bitSize from MINIMAL pragma of class Bits Cf. https://github.com/haskell/core-libraries-committee/issues/441 The function is deprecated for 12 years and has a default implementation, yet it was never removed from the MINIMAL pragma, putting library authors in a very awkward position. Let's finally remove bitSize from MINIMAL. - - - - - 3cc21e4c by Hannes Siebenhandl at 2026-10-01T20:22:59-04:00 Add regression test for #27641 - - - - - c35096f5 by Hannes Siebenhandl at 2026-10-01T20:23:00-04:00 Don't `:add` modules the loader will reject Only home modules can be actually added to the loader context, thus we only accept the module if it belongs to a home unit. - - - - - a563cb27 by Simon Jakobi at 2026-10-02T17:37:36-04:00 ci: accept modified changelog.d entries in lint-changelog The changelog guide says to extend an existing entry rather than add a new one when the feature is already documented. lint_changelog only counted added files, so such MRs failed before the validator ran. Fixes #27779. Assisted-by: Claude Fable 5.1 - - - - - 03082cd4 by Simon Jakobi at 2026-10-02T17:38:17-04:00 changelog.d: Fix warning flag name in the semaphore-v2 entry The entry refers to -Wsemaphore-version-mismatch, which does not exist. The warning GHC emits when it cannot use a -jsem semaphore, including on a protocol version mismatch, is -Wsemaphore-open-failure. Context: !15729, #25087 Assisted-by: Claude Fable 5.1 - - - - - a93705ee by Simon Jakobi at 2026-10-02T17:38:17-04:00 changelog.d: Fix the CLC proposal link in the T27455 entry The entry used the Sphinx :ref: role with a URL as its target. :ref: resolves only internal labels, so the generated release notes would show the proposal name without a link. Use the plain hyperlink form like the other entries. Context: !16274, #27455 Assisted-by: Claude Fable 5.1 - - - - - 54381079 by Hannes Siebenhandl at 2026-10-02T17:39:01-04:00 Extend the `TrustOverlay` for wired-in units The TrustOverlay only contained the `UnitId` of all on-disk units. However, wired-in units are referred to by their wired-in unit id, which is not the same as the on-disk unit id. Thus, trust checks for wired-in units failed because the lookup was using the wired-in unit, which wasn't present in the `TrustOverlay`. We fix #27834, by copying the trust info for wired-in unit ids. - - - - - f8cfb1a5 by Hécate Kleidukos at 2026-10-04T19:36:39+02:00 [CLC 341] Strict variants of mutable types This commit is the implementation of CLC Proposal 341 https://github.com/haskell/core-libraries-committee/issues/341 - - - - - 575c4bc6 by Rodrigo Mesquita at 2026-10-05T12:32:02-04:00 ttg: HsModuleName in the AST, ModuleName in GHC This commit makes the AST fully independent from GHC by parsing a "module name" as an `HsModuleName (= HText)` rather than constructing an `ModuleName (= FastString)` straight away. In the GHC side, everything remains as a `ModuleName`. We turn AST `HsModuleName`s into fast strings with the cheap `mkFastStringShortText` when we process the AST for manipulation within the compiler. There are no performance regressions introduced by this approach. This is the final piece of #21592 Alternative plans were discussed in gitlab.haskell.org/ghc/ghc/-/merge_requests/16546#note_694647, but the Simon suggested one won in simplicity and performance when compared against my attempt at implementing my original plan of having a family `ModuleNameP`. - - - - - b3b89d32 by mangoiv at 2026-10-05T22:03:32-04:00 hadrian: Persist the used flavour name in the build root (#20650) This executes the idea proposed in #20650, teaching Hadrian to persist the flavour used to build a build root. This both makes use of multiple build roots more ergonomic (as the user no longer needs to repeat themselves) and avoids a tiresome foot-gun (forgetting to specify a flavour, often wholly invalidating a build root). Closes #20650. Co-authored-by: Sylvain Henry <sylvain(a)haskus.fr> - - - - - f977837b by mangoiv at 2026-10-05T22:04:21-04:00 configure: fix sed script and subst tooldir script Fixes #27672 Adds sanity checking for SUBST_TOOLDIR Metric Decrease: LinkableUsage01 MultiLayerModulesTH_OneShot T10547 T12234 T12425 T13035 T13820 T18140 T18730 T18923 T9198 TcPlugin_RewritePerf mhu-perf - - - - - f1cb08be by Hannes Siebenhandl at 2026-10-05T22:05:03-04:00 Prepend in-memory unit database for backpack The packageDbFlags are stored in reverse order. Thus, prepending will ensure that the in-memory unit database is the last item on the unit database stack. Further, the in-memory unit database needs to be able to shadow units from earlier unit databases in the unit database stack. Moreover, a `-clear-package-db` would remove the in-memory database if it weren't the last item on the stack. Closes #27835 - - - - - 8d49ed42 by Kazu Yamamoto at 2026-10-06T19:37:25-04:00 Do not leave standard file descriptors free at startup (#24450) A process may be started with stdout closed -- `prog >&-` from a shell does exactly that. Nothing then reserves descriptor 1, and open(), pipe() and socket() hand out the lowest free descriptor, so the next descriptor the runtime creates for itself takes it: the ticker's pipe, or a capability's IO manager control pipe. 'GHC.Internal.IO.StdHandles.stdout' is a CAF, built the first time the program writes to stdout, which is long after that has happened. It builds a 'Handle' over descriptor 1, which now belongs to the runtime, and nothing reports an error because the descriptor is perfectly good. The program then writes its output into the runtime's own plumbing. What that looks like from the outside is a hang. The descriptor the Handle has taken over is the read end of a pipe, so poll() for POLLOUT on it never says yes and epoll_ctl() accepts a registration for it; the thread waiting to write blocks for ever. Closing the Handle at exit closes the runtime's descriptor, which is worse: the ticker then fails on every tick. 'hs_init_ghc' now opens /dev/null onto whichever of descriptors 0, 1 and 2 are closed, before the runtime creates any descriptor of its own. Each is opened for the access that descriptor would normally have, read-only for 0 and write-only for 1 and 2, so that writing to 'stdin' or reading from 'stdout' still fails rather than quietly succeeding against /dev/null. See Note [Standard file descriptors must be open]. Moving only the descriptors the runtime opens would not do: the first file the program itself opened would land on the free number instead. The fix has to leave no free number. A program run this way therefore finds stdout connected to /dev/null rather than failing with EBADF on the first write, which is what such a program would get from most other language runtimes. Co-Authored-By: Claude Opus 5 (1M context) <noreply(a)anthropic.com> - - - - - 65bcf9e9 by Simon Jakobi at 2026-10-06T19:38:09-04:00 changelog: Repair the sentence describing #27477 The description read "programs using could crash", the object of "using" having been lost. The synopsis already says which programs are affected, so drop the dangling word. Assisted-by: Claude Fable 5.1 - - - - - 15ece296 by mangoiv at 2026-10-08T15:14:56-04:00 ci: move hadrian/ghci into the lint category so it can be picked up by more runners Fixes #27817 - - - - - c0823135 by mangoiv at 2026-10-08T15:14:56-04:00 ci: make lint-adjacent jobs into platform independent - move lint jobs into lint-anyarch tag - unify lint jobs under the same platform independent container - - - - - f76464cf by Zubin Duggal at 2026-10-08T15:15:39-04:00 DmdAnal: Make AbsDmd neutral in maxDmd fixes #27845 - - - - - ffa56ae4 by sheaf at 2026-10-09T17:15:59+02:00 Preserve sign of zero when parsing -0.0# This commit leverages the recently added GHC.Types.Literal.Floating module in order to preserve the sign of negative zero from source-written floating-point literals. Fixes #27545 - - - - - d538cac9 by Facundo Domínguez at 2026-10-09T20:26:38-04:00 Propagate annotations to simple interfaces This allows annotations to be visible to plugins when run by haddock. The LiquidHaskell plugin needs the annotations, in particular. Fixes #26761 - - - - - 32c4f4ab by meooow25 at 2026-10-09T20:27:28-04:00 Bump containers submodule to 0.8.1 And fix affected tests. * T4086a: containers depends on template-haskell-lift now instead of template-haskell. * T22611: Updated to be less dependent on containers internals. - - - - - c786065e by sheaf at 2026-10-09T20:28:20-04:00 Use an explicit pattern match in toIfaceIdDetails The old wildcard pattern let this code bit rot: it did not properly account for recently added 'IdDetails' such as 'RepPolyId', which resulted in spurious 'pprTrace' messages that could even pollute HLS sessions. Fixes #23785 - - - - - e7cacf59 by sheaf at 2026-10-09T20:29:09-04:00 Take into account ifKind in freeNamesIfDecl Commit 3c2f4bb4 added the 'ifKind' field to various constructors of 'IfaceDecl', which preserves the original kind (before type synonym expansion) for better error messages. However, that commit forgot to update 'freeNamesIfDecl' correspondingly. This could result in a "urk! lookup local fingerpring" crash when e.g. a type's kind uses a type synonym defined later, as we failed to add a dependency on the type synonym during dependency analysis. Fixes #27916 - - - - - 41e80f41 by Simon Peyton Jones at 2026-10-11T14:38:51-04:00 Simplify the error-suppression mechanism in GHC.Tc.Errors In `GHC.Tc.Errors.reportWanteds` we suppress some errors in favour of others. But the mechanism had grown crufty, and #27331 exposed a bug. This MR makes it simpler and more uniform, by doing everything via the `ei_suppress` field of the ErrorItem. Claude then found another closely-related bug (see the review linked on !16564). That bug is immortalised in new test T18851d. I'm still not happy with `ignoreConstraint` but we can worry about that another day; I have not touched it. Main changes * Instead of /predicting/ when an error will be reported, we set `cec_error_reported` when an error is /actually/ reported. (I renamed it from `cec_suppress` to reflect this change.) Now errors are suppressed only when a preceding error has actually been reported. Simpler and more robust. See `Note [cec_error_reported: suppressing less-serious errors]` The big changes are in `reportWanteds` which looks very different. * New `Note [ei_suppress: suppressing confusing errors]` describes the (quite separate) `ei_suppress` mechanism for suppressing confusing errors, mainly arising from non-empty rewriter sets * In `tryTypeClassDefaulting`, instead of switching off type-class defaulting if there is an insoluble /anywhere/, we just switch it off locally when we find an insoluble sub-tree. See Note [When to do type-class defaulting] and (W5) in Note [ApproximateWC] * Greatly simplify `insolubleWantedCt`. * I made type-class-defaulting be a bit more eager, only switched off when a peer or ancestor (but not child) constraint is insoluble. See Note [When to do type-class defaulting]. Small refactorings * Rename `askNoErrs` to `askErrsFound` and flip its polarity * The code for "check if ei_suppress is true of all items" code is moved to `mkErrorItems` rather than in the large `reportWanteds`. * Code for `has_gadt_match` moves to `mkGivenErrorReporter`, rather than polluting the large `reportWanteds`. * Many tests with `-fdefer-type-errors` get more warnings, especially about ambiguous (Num a) constraints. This is by-design: see Note [Always warn with -fdefer-type-errors]. Previously GHC was not honouring this Note but now it is, hence the extra errors. - - - - - f217fc31 by Cheng Shao at 2026-10-11T14:39:33-04:00 compiler: ensure cross ghc --info output target unit ids Previously, for cross ghcs, the base/ghc/ghc-internal unit ids in --info output do not match the target unit ids reported by ghc-pkg, breaking cross ghc release builds with hash-unit-ids when being used with cabal 3.18. This patch fixes it by making --info output target unit ids. Fixes #27919. Co-authored-by: Codex <codex(a)openai.com> - - - - - d07a5176 by Simon Peyton Jones at 2026-10-13T18:10:39-04:00 Remove the Eq and Ord instances for ForAllTyFlag In Note [Comparing visibility] in GHC.Core.TyCo.Compare we read that "we always compare ForAllTyFlags with `eqForAllVis` or `cmpForAllVis`" But alas there was an Eq and Ord instance for ForAllTyFlag, which made it impossible to check this claim. So I made these changes: * Move the definition of ForAllTyFlag and its related functions from L.H.S.Specificity (where it did not belong, since L.H.S didn't use it) into GHC.Types.Var. * Remove the Eq and Ord instances for ForAllTyFlag * Deal with the fallout, by using `eqForAllVis` or related functions. * In interface files we use IfaceType as a key for a de-deduplication map See Note [Deduplication during iface binary serialisation] in GHC.Iface.Binary. For this we need /exact/ comparison, so we use a newtype wrapper for IfaceForAllTyFlag, and give use `cmpForAllTyFlagExactly` to implement its Ord instance. Tiresome but easy. * Rename `toIfaceForAllBndrs` to `toIfaceForAllTyBndrs` - - - - - ea5c054d by Simon Peyton Jones at 2026-10-13T18:10:39-04:00 Refactor type and coercion substitution This MR refactors type and coercion substitution so that they use TyCoMapper, rather than hand-rolled code. Fundamentally it's a simple idea, but I had to do quite a bit of refactoring to make it fly. I got Claude to help me this this refactoring, but I paid careful attention to every line of code. Main changes: * New module GHC.Core.TyCo.Make which defines TyCoMapper, and a bunch of other simple "smart constructors" for types and coercions. See GHC.Core.TyCo.Rep Note [The Type-related module hierarchy], esp (TRM1) * The new TyCoMapper has new fields `tcm_tcapp_ty` and `tcm_tcapp_co` to handle type-constructor applications. These replace `tcm_tycon`. * Rewrite GHC.Core.TyCo.Subst to use TyCoMapper * Rewrite GHC.Core.Type.expandTypeSynonyms to use TyCoMapper. * Implement `seqType` and `seqCo` with TyCoFolder. To to this I had to add a `tcf_lit` field to TyCoFolder. * A new module GHC.Utils.StrictIdentity to define a strict identity monad, which itself is used for substTyCoMapper :: TyCoMapper Subst StrictIdentity * I removed an apparently-unused instance for Binary Levity Refactoring `seq` functions * In GHC.Core.Seq, redefine `seqOneShot`, `seqRuleInfo`, and friends to return `SeqResult`, a new type defined in GHC.Types.Baseic, rather than `()`. We can define a Monoid instance for `SeqResult` that does the right thing. * This has knock-on effects across the compiler. - - - - - 34165e23 by Simon Peyton Jones at 2026-10-13T18:10:39-04:00 Refactor TyCoMapper to take a single monad; add StrictReaderT TyCoMapper used to be parameterised over both an environment and a monad, with fields like tcm_tyvar :: env -> TyVar -> m Type Now it is parameterised over just the monad: tcm_tyvar :: TyVar -> m Type If the mapping needs an environment, `m` is a reader monad over that environment. Many uses (e.g. zonkTcTypeMapper, swizzleMapper) need no environment at all, and used to pass a dummy (). The binder field becomes tcm_tycobinder :: forall r. TyCoVar -> ForAllTyFlag -> (TyCoVar -> m r) -> m r and runs the continuation in the extended environment. mapTyCoX is gone; only mapTyCo remains. To make this efficient, the reader monad must use the one-shot trick and be strict in the environment. So: * New module GHC.Utils.Monad.StrictReader defines newtype StrictReaderT r m a with hand-written instances. The builder of the pattern synonym `StrictReaderT` is a smart constructor that adds both `oneShot` and a bang on the environment, so every StrictReaderT computation is strict in the environment. See Note [Instances for StrictReaderT]. * ZonkT becomes type ZonkT = StrictReaderT ZonkEnv ZonkM becomes type ZonkM = StrictReaderT ZonkGblEnv IO replacing their own hand-written instances. * Substitution uses type SubstM = StrictReaderT Subst StrictIdentity substTyCoMapper :: TyCoMapper SubstM and similarly expandTypeSynonymMapper. * zonk_tycomapper :: TyCoMapper (ZonkT TcM) is now much simpler. * swizzleMapper uses StrictIdentity rather than Identity. * Module renaming, so that the strict monads are all peers in GHC.Utils.Monad: GHC.Utils.StrictIdentity ==> GHC.Utils.Monad.StrictIdentity GHC.Utils.Monad.State.Strict ==> GHC.Utils.Monad.StrictState alongside the new GHC.Utils.Monad.StrictReader. Co-Authored-By: Claude Opus 5.5 <noreply(a)anthropic.com> - - - - - c0299e15 by Simon Jakobi at 2026-10-13T18:11:23-04:00 testsuite: Line-buffer the driver's stdout Python block-buffers stdout when it is a pipe. This is the case for example in CI. As a result there is often no indication of progress at all until the run ends. To fix this, we configure it explicitly to use line buffering instead. stderr is reconfigured too, for consistency: Python line-buffers it by default since 3.9. The type-ignores are for mypy, which types these handles as TextIO — an interface without reconfigure. Fixes #12934. Assisted-by: Claude Fable 5 - - - - - 9b5beaa2 by Florian Ragwitz at 2026-10-13T18:12:05-04:00 hpc: Improve coverage semantics for instance methods and instances Users care about which of their explicitly written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. We therefore skip generating top-level boxes for inherited methods which will appear as uncovered with no clear indication as to why, and no way to fix other than exercising code the user has not written. Previously, top-level boxes for those inherited methods would use the instance head as their source span. Now that those boxes are gone, we can use that source span for another purpose: We introduce a new top-level box for each class instance with its instance head as the source span, and use that to indicate whether or not an instance has been covered at all. We do this by making any method of the instance, inherited/generated or otherwise, tick the box for the instance head. Excluded from this are methodless classes, which could never be covered using the current mechanism. This could be improved upon further. These changes apply to ticking for program coverage only, and don't affect source notes. Additionally, we update the scope of record selector ticking to be limited to program coverage as well, as the oversight to also extend it to source notes has previously caused bugs and because record selector ticking is coverage-specific. Fixes #17155, #15932. - - - - - 836ec50a by Simon Peyton Jones at 2026-10-13T18:12:54-04:00 Refactor fundeps again This MR fixes #27828; there was a bad scoping error in `trim_qtvs`. The main changes are * Refactor `trim_qtvs` completely to eliminate the bug. * Remove a redundant `apartnessCheck` from `mkTopOpenFamEqFDs`. * Lots of improvements to the Notes in FunDeps.hs I also did a couple of pure refactors: * I realised that we were carefully caching `cab_incomps` in each `CoAxBranch`, to make it more efficient to reduce a type family application, but we were not doing the same thing when computing relevance for functional dependencies; see Note [Relevance] in GHC.Tc.Solver.FunDeps. So I added `cab_overlaps`, which is now used in `noEarlierMatch`. * Use a proper data types, `AmIUnifying` and `OuterKindsFlag`, for two previously-Boolean arguments to `tc_unify_tys`. This is a pure refactor. - - - - - 889ef371 by Simon Peyton Jones at 2026-10-13T18:13:36-04:00 Refactor and simplify solver's unification code Ticket #27844 showed that GHC's constraint solver could miss an occurs check, and thereby build an infinite type. This patch significantly simplifes the code in GHC.Tc.Solver.Equality.canEqCanLHSFinish_try_unification GHC.Tc.Solver.Equality.canEqCanLHSFinish_no_unification It is now significantly simpler, and requires much less subtle reasoning to understand. Main changes * If `canEqCanLHSFinish_try_unification` fails to unify, it now /always/ calls `canEqCanLHSFinish_no_unification` rather than trying to finish the job itself. * `GHC.Tc.Solver.Monad.checkTypeEq` is moved from Monad into Equality, and renamed to `GHC.Tc.Solver.Equality.checkTypeEqNoUnification`. * `canEqCanLHSFinish_no_unification` calls `checkTypeEqNoUnification` to test the invariants for an inert equality. Before this MR there was a special case for `do_not_prevent_rewriting`, but that has gone; instead it's just a consequence of the flags passed to `checkTyEqRhs`, documented in the `PuOK` case of `canEqCanLHSFinish_no_unification`. * There is only one bit of "swap back" code, in `finish_no_unify` in `canEqCanLHSFinish_try_unification. Previously this code was duplicated. * `kickOutAfterFillingCoercionHole` should account for equalities with a TyFamLHS. See (KOC5) in Note [Kick out after filling a coercion hole] * No need to gather coercion holes in the `PuOK` case of `canEqCanLHSFinish_no_unification`. See documentation with that code. - - - - - f9193e53 by Simon Peyton Jones at 2026-10-13T18:13:37-04:00 One line fix to fallout from ...#27731, !16564, simplifying Tc.Errors machinery There was an over-eager assert! - - - - - cdd56b7a by Florian Ragwitz at 2026-10-13T18:14:19-04:00 Fix several sphinx errors and warnings from rendering the release notes The extension references which are removed here are for extension which were already previously undocumented, so just removing them seems fine for now. - - - - - 4f00da25 by Florian Ragwitz at 2026-10-13T18:14:19-04:00 Link to QualifiedStrings documentation - - - - - 110444a5 by Simon Jakobi at 2026-10-14T12:04:18+02:00 testsuite: Report timeouts of the compile and pre_cmd steps as such Since b1cafb82872 a timed-out run step fails with "bad exit code (99): test timeout", but a timeout in the compile step still showed up as "exit code non-0", and in the pre_cmd step as "pre_cmd failed: 99". Worse, in a compile_fail test the timeout counted as the expected failure, so the test was reported as a stderr mismatch. Now every step uses the same message, which also names the step and the limit that was hit, e.g. compile: bad exit code (99): timed out after 300s so that one can pick a suitable timeout multiplier from the log. Context: #15963 Assisted-by: Claude Fable 5.1 - - - - - a881b105 by Simon Jakobi at 2026-10-14T12:04:30+02:00 testsuite: Report timeouts in their own summary category Timed-out tests were listed among the unexpected failures, where they are easy to mistake for genuine regressions, particularly on overloaded CI runners. They now get their own "Timeouts:" section and count in the summary, like unexpected stat failures, and their own type in the JUnit report. They still count towards the unexpected TEST= list and the non-zero exit code. Fixes #15963 Assisted-by: Claude Fable 5.1 - - - - - d2b01f53 by Simon Jakobi at 2026-10-14T12:04:30+02:00 DEMO, DO NOT MERGE: tests that time out at every step Four tests that time out on purpose in the compile, compile_fail, run and pre_cmd steps, so the new timeout reporting can be seen in the CI logs while reviewing. To be dropped before merging. Context: #15963 Assisted-by: Claude Fable 5.1 - - - - - 576 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/hello.hs - + changelog.d/24450 - + changelog.d/25763-cmdline-opt - + changelog.d/26610 - changelog.d/26616 - + changelog.d/26761 - + changelog.d/27641 - + changelog.d/27732 - + changelog.d/27845 - + changelog.d/T23785 - changelog.d/T27329 - changelog.d/T27455 - + changelog.d/T27545 - + changelog.d/T27629 - + changelog.d/T27731 - + changelog.d/T27788-js-selector - + changelog.d/T27828 - + changelog.d/T27830-rts-flag-bounds - + changelog.d/T27844 - + changelog.d/T27916 - + changelog.d/boxing-family - + changelog.d/clc-341-strict-mutable-data-types - + changelog.d/clc-421 - + changelog.d/fix-compacting-gc-constr-27649 - + changelog.d/fix-control0-mask-trampoline - + changelog.d/fix-cross-ghc-info-unit-id - + changelog.d/fix-parallel-gc-selector-race-27477 - + changelog.d/fix-threadlabel-segfault-27618 - + changelog.d/hadrian-persist-flavour - + changelog.d/hpc-classinsts - + changelog.d/select-io-manager - changelog.d/semaphore-v2 - changelog.d/tcplugin_init.md - changelog.d/unit-index - compiler/GHC.hs - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/Modules.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/WiredIn/Types.hs - + compiler/GHC/Builtin/WiredIn/Types/Box.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Show.hs - compiler/GHC/Cmm/GenericOpt.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToAsm/Dwarf/Types.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs - compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs - compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs - compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs - compiler/GHC/CmmToAsm/Reg/Linear/State.hs - compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Wasm/Asm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToC.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Coercion/Axiom.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - + compiler/GHC/Core/Make/BigTuple.hs - + compiler/GHC/Core/Make/Box.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CallerCC.hs - compiler/GHC/Core/Opt/CallerCC/Types.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Reduction.hs - compiler/GHC/Core/Seq.hs - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/TyCo/FVs.hs - + compiler/GHC/Core/TyCo/Make.hs - + compiler/GHC/Core/TyCo/Make.hs-boot - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Rep.hs-boot - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Type.hs-boot - compiler/GHC/Core/Unify.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToIface.hs-boot - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Data/FastString.hs - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension/Pass.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Debug.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Iface/Type.hs-boot - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/TagSig.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Subst.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Symbols.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Env.hs - compiler/GHC/Tc/Zonk/Monad.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/CompleteMatch.hs - compiler/GHC/Types/Cpr.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name/Env.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/TyThing/Ppr.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Map.hs - compiler/GHC/Types/Unique/Set.hs - compiler/GHC/Types/Unique/Supply.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Types/Var.hs-boot - compiler/GHC/Types/Var/Set.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Module.hs - compiler/GHC/Unit/Module/Env.hs - + compiler/GHC/Unit/Module/Name.hs - compiler/GHC/Unit/Parser.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Unit/Types.hs-boot - compiler/GHC/Utils/Binary.hs - + compiler/GHC/Utils/Monad/StrictIdentity.hs - + compiler/GHC/Utils/Monad/StrictReader.hs - compiler/GHC/Utils/Monad/State/Strict.hs → compiler/GHC/Utils/Monad/StrictState.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - compiler/Language/Haskell/Syntax/Specificity.hs - compiler/Language/Haskell/Syntax/Text.hs - compiler/ghc.cabal.in - distrib/configure.ac.in - docs/users_guide/exts/literals.rst - docs/users_guide/exts/type_data.rst - docs/users_guide/runtime_control.rst - ghc/GHC/Driver/Session/Mode.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/doc/flavours.md - hadrian/ghci-multi-cabal.in - hadrian/src/Builder.hs - hadrian/src/Rules.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Control/Concurrent/Chan.hs - + libraries/base/src/Control/Concurrent/Chan/Strict.hs - libraries/base/src/Control/Concurrent/MVar.hs - + libraries/base/src/Control/Concurrent/MVar/Strict.hs - libraries/base/src/Data/IORef.hs - + libraries/base/src/Data/IORef/Strict.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/containers - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/Bits.hs - + libraries/ghc-internal/src/GHC/Internal/Box.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - linters/lint-codes/LintCodes/Static.hs - m4/subst_tooldir.m4 - rts/Capability.c - rts/Continuation.c - rts/ContinuationOps.cmm - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/Interpreter.c - rts/Messages.c - rts/Prelude.h - rts/PrimOps.cmm - rts/Printer.c - rts/RaiseAsync.c - rts/RtsFlags.c - rts/RtsStartup.c - rts/STM.c - rts/Schedule.c - rts/Sparks.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Trace.h - rts/configure.ac - rts/include/rts/Flags.h - rts/include/rts/RtsToHsIface.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/GC.h - rts/include/stg/MiscClosures.h - rts/include/stg/Prim.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - + rts/posix/SelectBis.c - + rts/posix/SelectBis.h - rts/posix/Timeout.c - rts/posix/Timeout.h - rts/prim/bitrev.c - rts/prim/bswap.c - rts/rts.cabal - rts/sm/Compact.c - rts/sm/Evac.c - rts/sm/GC.c - rts/sm/GCUtils.c - rts/sm/MBlock.c - rts/sm/NonMoving.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - rts/sm/Sweep.c - testsuite/driver/junit.py - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/arrows/should_run/all.T - + testsuite/tests/arrows/should_run/arrowrun005.hs - + testsuite/tests/arrows/should_run/arrowrun005.stdout - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T - + testsuite/tests/bytecode/T27633/Obj.hs - + testsuite/tests/bytecode/T27633/T27633a.hs - + testsuite/tests/bytecode/T27633/T27633a.stdout - + testsuite/tests/bytecode/T27633/T27633b.hs - + testsuite/tests/bytecode/T27633/T27633b.stdout - + testsuite/tests/bytecode/T27633/all.T - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/deSugar/should_compile/T25065a.hs - testsuite/tests/deSugar/should_compile/all.T - + testsuite/tests/deSugar/should_run/T20864.hs - + testsuite/tests/deSugar/should_run/T20864.stdout - + testsuite/tests/deSugar/should_run/T25065b.hs - + testsuite/tests/deSugar/should_run/T25065b.stdout - testsuite/tests/deSugar/should_run/all.T - + testsuite/tests/dmdanal/should_run/T27845.hs - + testsuite/tests/dmdanal/should_run/T27845.stdout - + testsuite/tests/dmdanal/should_run/T27845_Lib.hs - + testsuite/tests/dmdanal/should_run/T27845b.hs - + testsuite/tests/dmdanal/should_run/T27845b.stdout - + testsuite/tests/dmdanal/should_run/T27845b_Lib.hs - testsuite/tests/dmdanal/should_run/all.T - + testsuite/tests/driver/T15963-demo/PreCmd.hs - + testsuite/tests/driver/T15963-demo/Slow.hs - + testsuite/tests/driver/T15963-demo/SlowFail.hs - + testsuite/tests/driver/T15963-demo/SlowFail.stderr - + testsuite/tests/driver/T15963-demo/SlowRun.hs - + testsuite/tests/driver/T15963-demo/all.T - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci.debugger/scripts/T27633c.hs - + testsuite/tests/ghci.debugger/scripts/T27633c.script - + testsuite/tests/ghci.debugger/scripts/T27633c.stdout - + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/ghci/prog020/ghci.prog020a.stderr - testsuite/tests/ghci/prog020/ghci.prog020b.stderr - testsuite/tests/ghci/prog021/prog021a.stderr - testsuite/tests/ghci/prog021/prog021b.stderr - testsuite/tests/ghci/prog022/ghci.prog022a.stderr - testsuite/tests/ghci/prog022/ghci.prog022b.stderr - testsuite/tests/ghci/prog022/ghci.prog022c.stderr - testsuite/tests/ghci/prog022/ghci.prog022d.stderr - testsuite/tests/ghci/prog022/ghci.prog022e.stderr - testsuite/tests/ghci/prog022/ghci.prog022f.stderr - testsuite/tests/ghci/scripts/Defer02.stderr - + testsuite/tests/ghci/scripts/T27641.script - + testsuite/tests/ghci/scripts/T27641.stderr - + testsuite/tests/ghci/scripts/T27641.stdout - + testsuite/tests/ghci/scripts/T27834.hs - + testsuite/tests/ghci/scripts/T27834.script - + testsuite/tests/ghci/scripts/T27834.stdout - testsuite/tests/ghci/scripts/all.T - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/hiefile/should_run/T24544.hs - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T - + testsuite/tests/indexed-types/should_compile/T27828.hs - + testsuite/tests/indexed-types/should_compile/T27828a.hs - + testsuite/tests/indexed-types/should_compile/T27828b.hs - testsuite/tests/indexed-types/should_compile/all.T - testsuite/tests/indexed-types/should_fail/T9662.stderr - + testsuite/tests/indexed-types/should_run/T27331.hs - + testsuite/tests/indexed-types/should_run/T27331.stdout - + testsuite/tests/indexed-types/should_run/T27331b.hs - + testsuite/tests/indexed-types/should_run/T27331b.stdout - + testsuite/tests/indexed-types/should_run/T27331b_Plugin.hs - testsuite/tests/indexed-types/should_run/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/javascript/T27788.hs - + testsuite/tests/javascript/T27788.stdout - testsuite/tests/javascript/all.T - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod130.stderr - testsuite/tests/module/mod185.stderr - + testsuite/tests/numeric/should_run/T27545.hs - + testsuite/tests/numeric/should_run/T27545.stdout - testsuite/tests/numeric/should_run/all.T - testsuite/tests/overloadedstrings/should_fail/T25926.stderr - testsuite/tests/overloadedstrings/should_fail/T27124.stderr - testsuite/tests/package/T4806a.stderr - testsuite/tests/package/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/plugins/T26761.hs - + testsuite/tests/plugins/T26761.stderr - + testsuite/tests/plugins/T26761Plugin.hs - + testsuite/tests/plugins/T26761a.hs - testsuite/tests/plugins/all.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T17697.stderr - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs - testsuite/tests/rename/should_fail/T15607.stderr - testsuite/tests/rename/should_fail/T19843b.stderr - + testsuite/tests/rts/T24450.hs - + testsuite/tests/rts/T24450.stderr - + testsuite/tests/rts/T27477.hs - + testsuite/tests/rts/T27477.stdout - + testsuite/tests/rts/T27618.hs - + testsuite/tests/rts/T27618.stdout - + testsuite/tests/rts/T27649.hs - + testsuite/tests/rts/T27649.stdout - testsuite/tests/rts/all.T - + testsuite/tests/rts/continuations/T27651.hs - + testsuite/tests/rts/continuations/T27651.stdout - testsuite/tests/rts/continuations/all.T - testsuite/tests/rts/rtsflags001.stderr-ws-32 - testsuite/tests/rts/rtsflags001.stderr-ws-64 - testsuite/tests/safeHaskell/ghci/p4.stderr - testsuite/tests/safeHaskell/ghci/p6.stderr - testsuite/tests/simplCore/should_compile/Makefile - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - testsuite/tests/simplCore/should_compile/T22611.hs - testsuite/tests/simplCore/should_compile/T22611.stderr - + testsuite/tests/simplCore/should_compile/T22611a.hs - + testsuite/tests/simplCore/should_compile/T27629.hs - + testsuite/tests/simplCore/should_compile/T27629.stderr - + testsuite/tests/simplCore/should_compile/T27629Plugin.hs - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/type-data/should_fail/T27732a.hs - + testsuite/tests/type-data/should_fail/T27732a.stderr - + testsuite/tests/type-data/should_fail/T27732b.hs - + testsuite/tests/type-data/should_fail/T27732b.stderr - + testsuite/tests/type-data/should_fail/T27732c.hs - + testsuite/tests/type-data/should_fail/T27732c.stderr - + testsuite/tests/type-data/should_fail/T27732d.hs - + testsuite/tests/type-data/should_fail/T27732d.stderr - + testsuite/tests/type-data/should_fail/T27732e.hs - + testsuite/tests/type-data/should_fail/T27732e.stderr - + testsuite/tests/type-data/should_fail/T27732f.hs - + testsuite/tests/type-data/should_fail/T27732f.stderr - testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr - testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr - testsuite/tests/type-data/should_fail/all.T - testsuite/tests/typecheck/should_compile/T11254.stderr - testsuite/tests/typecheck/should_compile/T15370.stderr - + testsuite/tests/typecheck/should_compile/T27916.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/ClassOperator.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/DoExpansion3.stderr - testsuite/tests/typecheck/should_fail/FunDepOrigin1b.hs - testsuite/tests/typecheck/should_fail/T12785b.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr - + testsuite/tests/typecheck/should_fail/T18851e.hs - + testsuite/tests/typecheck/should_fail/T18851e.stderr - + testsuite/tests/typecheck/should_fail/T18851f.hs - + testsuite/tests/typecheck/should_fail/T18851f.stderr - testsuite/tests/typecheck/should_fail/T22940.stderr - testsuite/tests/typecheck/should_fail/T26823.stderr - + testsuite/tests/typecheck/should_fail/T27731.hs - + testsuite/tests/typecheck/should_fail/T27731.stderr - + testsuite/tests/typecheck/should_fail/T27844.hs - + testsuite/tests/typecheck/should_fail/T27844.stderr - testsuite/tests/typecheck/should_fail/T5691.stderr - testsuite/tests/typecheck/should_fail/T7437.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/mc24.stderr - testsuite/tests/typecheck/should_fail/tcfail019.stderr - testsuite/tests/typecheck/should_fail/tcfail189.stderr - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/deriveConstants/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eda167c873c2ccaf81e20416aa662d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eda167c873c2ccaf81e20416aa662d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/supersven/hadrian-cross-stage3] 2 commits: hadrian: Reduce libraryStage equation duplication
by Sven Tennie (＠supersven) 15 Oct '26

15 Oct '26

Sven Tennie pushed to branch wip/supersven/hadrian-cross-stage3 at Glasgow Haskell Compiler / GHC Commits: 55892b34 by Sven Tennie at 2026-10-15T09:18:32+02:00 hadrian: Reduce libraryStage equation duplication The same code was duplicated in a couple of places. - - - - - 0484130d by Sven Tennie at 2026-10-15T11:59:57+02:00 hadrian: Adjust path of m4/ directory Reflect the structure of the project repo's root directory and copy m4/ next to distrib/. The similarity should make it easier to understand as one doesn't have to mentally map paths. - - - - - 3 changed files: - distrib/configure.ac.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== distrib/configure.ac.in ===================================== @@ -9,7 +9,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [@ProjectVersion@], [ dnl See /configure.ac for rationale. AC_PREREQ([2.69]) -AC_CONFIG_MACRO_DIRS([m4]) +AC_CONFIG_MACRO_DIRS([../m4]) dnl-------------------------------------------------------------------- dnl * Deal with arguments telling us gmp is somewhere odd ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -6,7 +6,7 @@ module Oracles.Setting ( -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, - libsuf, ghcVersionStage, shPath, targetStage, crossStage, queryTarget, queryTargetTarget, + libsuf, ghcVersionStage, shPath, targetStage, crossStage, libraryStageFor, queryTarget, queryTargetTarget, isHostStage, -- ** Target platform things @@ -261,3 +261,22 @@ crossStage st = do st_target <- targetStage (succStage st) st_host <- targetStage st return (targetPlatformTriple st_target /= targetPlatformTriple st_host) + +-- | The 'Stage' whose libraries and package database are used by a compiler +-- built at (or running from) @compilerStage@. +-- +-- Usually @compilerStage@ itself, but differs in two cases: +-- +-- * 'Stage0' has no library or package database of its own; it uses 'Stage1'\'s. +-- * A cross compiler uses the successor compilerStage's libraries (built for the +-- target, not the host). +libraryStageFor :: Stage -> Action Stage +libraryStageFor compilerStage = do + isCross <- + if compilerStage < Stage3 + then + crossStage compilerStage + else return False + return $ case compilerStage of + Stage0 {} -> Stage1 + _ -> if isCross then succStage compilerStage else compilerStage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -256,18 +256,7 @@ generateRules = do prefix = root -/- stageString compilerStage -/- "lib" go gen file = generate file (semiEmptyTarget compilerStage) gen (prefix -/- "settings") %> \out -> do - -- @compilerStage@ is the stage that builds the compiler, i.e. the - -- binary whose settings these are; @libraryStage@ is the stage - -- whose libraries and package DB that compiler uses. The two - -- differ in two cases: Stage0 has no library or package DB of its - -- own (the bootstrapping compiler uses Stage1's), and cross - -- stages use the successor stage's libraries (a cross compiler - -- requires libs from the successor stage, otherwise they are - -- compiled for the host and not the target). - isCross <- crossStage compilerStage - let libraryStage = case compilerStage of - Stage0 {} -> Stage1 - _ -> if isCross then succStage compilerStage else compilerStage + libraryStage <- libraryStageFor compilerStage pkgDb <- packageDbPath (PackageDbLoc libraryStage Final) -- addTrailingPathSeparator needed: makeRelativeNoSysLink uses -- splitPath where "lib" and "lib/" are distinct components. @@ -288,9 +277,7 @@ generateRules = do isCrossStage <- if compilerStage < Stage3 then expr (crossStage compilerStage) else pure False - let libraryStage = case compilerStage of - Stage0 {} -> Stage1 - _ -> if isCrossStage then succStage compilerStage else compilerStage + libraryStage <- expr (libraryStageFor compilerStage) tgt <- expr (targetStage libraryStage) pure $ show tgt { tgtLocallyExecutable = not isCrossStage } @@ -505,24 +492,36 @@ bindistRules = do , crossStageInterps ] - -- We can build two kinds of bindists: Regular Stage2 (including - -- cross-compilers) and fully cross-compiled Stage3. To avoid - -- race-conditions, stale files, etc. build the `configure` scripts as part - -- of the stage's _build files. This requires copying several files such that - -- they are available to the autoconf run. + -- Note [Bindist configure autoconf srcdir] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We can build binary distributions for several stages. These may need + -- different `configure` scripts. To avoid race-conditions on temporary + -- autoconf files (including `configure`), we generate those in the stages' + -- dedicated build folders (`_build/<stage>`). + -- + -- The generated `configure.ac` lives in `_build/<stage>/distrib`, while the + -- m4 macros are one level up in _build/<stage>/m4. This mirrors the + -- repository layout, where `distrib/configure.ac.in` refers to the macros + -- via AC_CONFIG_MACRO_DIRS([../m4]) (i.e. the repository's top-level `m4/`). + -- Keeping the same relative layout means the template needs no change. + -- + -- We deliberately do *not* copy the top-level `aclocal.m4`: its m4_include + -- directives are relative to the directory aclocal first ran in. Instead we + -- run autoreconf next to the staged `configure.ac` and let aclocal pick the + -- macro directory up from its AC_CONFIG_MACRO_DIRS([../m4]), regenerating + -- `aclocal.m4` with `../m4/...` includes that resolve from there. + -- + -- The other copied files need to be present for autoconf and/or autoreconf. forM_ [Stage1, Stage2] $ \stage -> do - let distribDir = root -/- stageString stage -/- "distrib" - - distribDir -/- "aclocal.m4" %> \out -> do - top <- topDirectory - copyFile (top -/- "aclocal.m4") out + let stageDir = root -/- stageString stage + distribDir = stageDir -/- "distrib" forM_ ["config.sub", "config.guess", "install-sh"] $ \f -> distribDir -/- f %> \out -> do top <- topDirectory copyFile (top -/- f) out - distribDir -/- "m4/*.m4" %> \out -> do + stageDir -/- "m4/*.m4" %> \out -> do top <- topDirectory copyFile (top -/- "m4" -/- takeFileName out) out @@ -533,9 +532,8 @@ bindistRules = do , distribDir -/- "config.sub" , distribDir -/- "config.guess" , distribDir -/- "install-sh" - , distribDir -/- "aclocal.m4" ] - ++ [ distribDir -/- "m4" -/- takeFileName f | f <- m4Files ] + ++ [ stageDir -/- "m4" -/- takeFileName f | f <- m4Files ] -- Note [Autoreconf unix paths from ACLOCAL_PATH] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -556,12 +554,12 @@ bindistRules = do interp = interpretInContext (semiEmptyTarget Stage2) getTarget stage = interp . queryTarget stage getLibTarget executableStage f = do - isCross <- crossStage executableStage - getTarget (if isCross then succStage executableStage else executableStage) f + libStage <- libraryStageFor executableStage + getTarget libStage f -- | 'targetSupportsSMP' lifted to the library stage (see 'getLibTarget'). libStageSupportsSMP stage = do - isCross <- crossStage stage - targetSupportsSMP (if isCross then succStage stage else stage) + libStage <- libraryStageFor stage + targetSupportsSMP libStage -- | The unit id of @pkg@ in the stage whose libraries ship with the -- bindist, i.e. the library stage of the implicit bindist config. For -- cross compilers these are the target-architecture unit ids, as View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c64ae620c8413a3d49660f2629f3e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c64ae620c8413a3d49660f2629f3e5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] testsuite: Use mkWeakMVar in memo001/memo002
by Marge Bot (＠marge-bot) 15 Oct '26

15 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f93d523c by Luite Stegeman at 2026-10-15T04:56:34-04:00 testsuite: Use mkWeakMVar in memo001/memo002 mkWeakPtr in the memo001/memo001 tests created weak pointers with the MVar box as the key, which is fragile in the presence of optimization. The fix is using mkWeakMVar, keying on the primitive MVar# instead. Fixes #27924 and #27396 - - - - - 3 changed files: - libraries/base/tests/Memo1.lhs - libraries/base/tests/Memo2.lhs - libraries/base/tests/all.T Changes: ===================================== libraries/base/tests/Memo1.lhs ===================================== @@ -13,10 +13,10 @@ module Memo1 where import System.Mem.StableName ( StableName, makeStableName, hashStableName ) -import System.Mem.Weak ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize ) +import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize ) import Data.Array.IO ( IOArray, newArray, readArray, writeArray ) import System.IO.Unsafe ( unsafePerformIO ) -import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) +import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar, mkWeakMVar ) \end{code} ----------------------------------------------------------------------------- @@ -78,7 +78,7 @@ lazyMemoSized size f = let (table,weak) = unsafePerformIO ( do { tbl <- newArray (0,size) [] ; mvar <- newMVar (size,tbl) - ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size)) + ; weak <- mkWeakMVar mvar (table_finalizer tbl size) ; return (mvar,weak) }) in memo' f table weak ===================================== libraries/base/tests/Memo2.lhs ===================================== @@ -13,10 +13,10 @@ module Memo2 where import System.Mem.StableName ( StableName, makeStableName, hashStableName ) -import System.Mem.Weak ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize ) +import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize ) import Data.Array.IO ( IOArray, newArray, readArray, writeArray ) import System.IO.Unsafe ( unsafePerformIO ) -import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) +import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar, mkWeakMVar ) \end{code} ----------------------------------------------------------------------------- @@ -78,7 +78,7 @@ lazyMemoSized size f = let (table,weak) = unsafePerformIO ( do { tbl <- newArray (0,size) [] ; mvar <- newMVar (size,tbl) - ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size)) + ; weak <- mkWeakMVar mvar (table_finalizer tbl size) ; return (mvar,weak) }) in memo' f table weak ===================================== libraries/base/tests/all.T ===================================== @@ -135,8 +135,7 @@ test('list003', when(fast(), skip), compile_and_run, ['']) test('isSuffixOf', normal, compile_and_run, ['']) test('memo001', [extra_files(['Memo1.lhs']), - extra_run_opts('+RTS -A10k -RTS'), - expect_broken_for(27396, opt_ways)], multimod_compile_and_run, + extra_run_opts('+RTS -A10k -RTS')], multimod_compile_and_run, ['memo001', '']) test('memo002', [extra_files(['Memo2.lhs']), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f93d523cf3f28e8a7fe8b8bfef8037f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f93d523cf3f28e8a7fe8b8bfef8037f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Make exprFreeVars deep
by Marge Bot (＠marge-bot) 15 Oct '26

15 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 033ba59c by sheaf at 2026-10-15T04:55:44-04:00 Make exprFreeVars deep exprFreeVars used to be a shallow free-variable finder (it didn't look into kinds), but most callers wanted it to be deep. In particular, 'exprFreeVars' is often used to seed an 'InScopeSet', and that must contain the /deep/ free variables. This commit makes it deep, which allows us to get rid of calls to 'closeOverKinds' or other workarounds for shallowness in: - 'GHC.Core.Opt.Simplify.Utils.abstractFloats' - 'GHC.HsToCore.Binds.dsSpec_help' - 'GHC.Core.Opt.Arity.etaBodyForJoinPoint' - 'GHC.Core.FVs.freeVars' - 'GHC.Core.Lint.lintCoreRule' We also remove 'deepExprsFreeVarsDSet' and 'closeOverKindsDSet'. Other places needed a little bit more care, in particular to properly handle coercion variables free in kinds: - 'GHC.Core.Opt.Specialise.specHeader' quantifies over the binder of an unspecialised argument directly, instead of computing the free Ids of the argument. - 'GHC.HsToCore.dsWarnRuleShadowing' filters out 'CoVar's. - 'GHC.Core.Opt.SpecConstr.callToPat' had some ad-hoc logic to compute argument pattern types and a workaround with 'expandTypeSynonyms'. That logic is removed in favour of a new 'argsToPats' function which directly computes the argument pattern types by instantiating the type of the head of the call pattern. Fixes #27936 - - - - - 16 changed files: - + changelog.d/27936 - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/Type.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Var/FV.hs - + testsuite/tests/simplCore/should_compile/T27936.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/27936 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: + Ensure in-scope set computations always look into kinds, avoiding + "needInScope" assertion failures in various places in the compiler. +mrs: !16799 +issues: #27936 ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -11,18 +11,17 @@ Taken quite directly from the Peyton Jones/Lester paper. module GHC.Core.FVs ( -- * Free variables of expressions and binding groups exprFreeVars, exprsFreeVars, - exprFreeVarsDSet, + exprFreeVarsDSet, exprsFreeVarsDSet, exprFreeVarsList, exprsFreeVarsList, exprFreeIds, exprsFreeIds, exprFreeIdsDSet, exprsFreeIdsDSet, exprFreeIdsList, exprsFreeIdsList, bindFreeVars, - -- * Selective shallow free variables of expressions + -- * Selective free variables of expressions InterestingVarFun, exprSomeFreeVars, exprsSomeFreeVars, exprSomeFreeVarsList, exprsSomeFreeVarsList, exprsSomeFreeVarsDSet, - deepExprsFreeVarsDSet, -- * Free variables of Rules, Vars and Ids bndrTypeTyCoFVs, bndrFVs, dBndrFreeVars, @@ -73,95 +72,118 @@ import GHC.Builtin.WiredIn.Types( unrestrictedFunTyConName ) import GHC.Builtin.WiredIn.Prim( fUNTyCon ) import GHC.Data.Maybe( orElse ) -import GHC.Utils.EndoOS import GHC.Utils.Misc import GHC.Utils.Panic.Plain {- ************************************************************************ * * - Find the shallow free variables of term + Free variables of terms * * ************************************************************************ Note [Free variables of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This function simply finds the shallow free variables of an expression. -So far as type variables are concerned, it only finds tyvars that are - * free in type arguments, - * free in the type of a binder, -but not those that are free in the type of variable occurrences. - -(FVE1) For /types/ we have a shallow free-var finder and a deep free-var finder, - both implemented via TyCoFolder. For /terms/ we have just one free-var - finder (shallow). - - If we want the deep free vars (as in `deepExprsFreeVarsDSet`) we use - `closeOverKinds`. There is no deep reason for this. Maybe we should - make a folder for terms as well. --} +'exprFreeVars' computes the /deep/ free variables of an expression, in the +sense of Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs: + +(FVE1) An occurrence of a variable `v` contributes `v` together with the deep + free variables of v's type (and, for an Id, of its multiplicity). +The selective variants, e.g. 'exprSomeFreeVars', are also deep. +They only collect interesting free variables, and entirely skip looking into +the kind of non-interesting free variables. + +The type of a variable is traversed only when the variable is first collected, +so each free variable's type is visited at most once per call; see +Note [Computing deep free variables] in GHC.Core.TyCo.FVs. +-} -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVars :: CoreExpr -> VarSet exprFreeVars = dVarSetToVarSet . exprFreeVarsDSet -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVarsDSet :: CoreExpr -> DVarSet exprFreeVarsDSet = runFVSelective isLocalVar . exprFVs --- | Find all locally-defined free Ids or type variables in several expressions +-- | Find all locally-defined free Ids or type variables in several expressions, -- returning a non-deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = dVarSetToVarSet . exprsFreeVarsDSet --- | Find all locally-defined free Ids or type variables in several expressions +-- | Find all locally-defined free Ids or type variables in several expressions, -- returning a deterministically ordered list. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVarsList :: [CoreExpr] -> [Var] exprsFreeVarsList = runFVSelectiveList isLocalVar . exprsFVs +-- | Find all locally-defined free Ids or type variables in several expressions, +-- returning a deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVarsDSet :: [CoreExpr] -> DVarSet exprsFreeVarsDSet = runFVSelective isLocalVar . exprsFVs -deepExprsFreeVarsDSet :: [CoreExpr] -> DVarSet --- See (FVE1) in Note [Free variables of an expression] -deepExprsFreeVarsDSet = closeOverKindsDSet . exprsFreeVarsDSet - -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministically ordered list. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVarsList :: CoreExpr -> [Var] exprFreeVarsList = dVarSetElems . exprFreeVarsDSet --- | Find all locally-defined free Ids in an expression -exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +-- | Find all locally-defined free Ids in an expression. +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIds :: CoreExpr -> IdSet exprFreeIds = dVarSetToVarSet . exprFreeIdsDSet -exprsFreeIds :: [CoreExpr] -> IdSet -- Find all locally-defined free Ids +-- | Find all locally-defined free Ids in several expressions. +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIds :: [CoreExpr] -> IdSet exprsFreeIds = dVarSetToVarSet . exprsFreeIdsDSet -- | Find all locally-defined free Ids in an expression -- returning a deterministic set. -exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIdsDSet :: CoreExpr -> DIdSet exprFreeIdsDSet = runFVSelective isLocalId . exprFVs -- | Find all locally-defined free Ids in several expressions -- returning a deterministic set. -exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet exprsFreeIdsDSet = runFVSelective isLocalId . exprsFVs -- | Find all locally-defined free Ids in an expression -- returning a deterministically ordered list. -exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIdsList :: CoreExpr -> [Id] exprFreeIdsList = dVarSetElems . exprFreeIdsDSet -- | Find all locally-defined free Ids in several expressions -- returning a deterministically ordered list. -exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIdsList :: [CoreExpr] -> [Id] exprsFreeIdsList = dVarSetElems . exprsFreeIdsDSet --- | Find all locally defined free Ids in a binding group +-- | Find all locally-defined free Ids or type variables in a binding group. +-- +-- The result is deep; see Note [Free variables of an expression]. bindFreeVars :: CoreBind -> VarSet bindFreeVars = runFVSelectiveSet isLocalVar . bind_fvs @@ -171,6 +193,8 @@ bind_fvs (Rec prs) = addBndrsSelectiveFV (map fst prs) $ mapUnionFV rhs_fvs prs -- | Finds free variables in an expression selected by a predicate +-- +-- See Note [Free variables of an expression]. exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> VarSet @@ -221,30 +245,25 @@ addCoreBndrsFV :: [CoreBndr] -> SelectiveDFV -> SelectiveDFV addCoreBndrsFV bndrs fv = foldr addCoreBndrFV fv bndrs unitFV :: Var -> SelectiveDFV --- Deals with an occurrence --- Shallow: does not look at the kind -unitFV v = MkFV (\env -> EndoOS (do_it env)) - where - do_it (bvs, is_interesting) acc - | v `elemVarSet` bvs = acc -- First exclude the bound vars - | not (is_interesting v) = acc -- The "selective" bit - | v `elemDVarSet` acc = acc - | otherwise = acc `extendDVarSet` v +-- Deals with an occurrence: the variable and, if it is newly collected, +-- the free variables of its type and multiplicity. +-- See (FVE1) in Note [Free variables of an expression] +unitFV = deepSelUnitFV bndrTypeTyCoFVs exprsFVs :: [CoreExpr] -> SelectiveDFV exprsFVs = mapUnionFV exprFVs exprFVs :: CoreExpr -> SelectiveDFV -exprFVs (Type ty) = shallowSelTypeFV ty -exprFVs (Coercion co) = shallowSelCoFV co +exprFVs (Type ty) = deepSelTypeFV ty +exprFVs (Coercion co) = deepSelCoFV co exprFVs (Var var) = unitFV var exprFVs (Lit _) = mempty exprFVs (Tick t expr) = tickish_fvs t `mappend` exprFVs expr exprFVs (App fun arg) = exprFVs fun `mappend` exprFVs arg exprFVs (Lam bndr body) = addCoreBndrFV bndr (exprFVs body) -exprFVs (Cast expr co) = exprFVs expr `mappend` shallowSelCoFV co +exprFVs (Cast expr co) = exprFVs expr `mappend` deepSelCoFV co exprFVs (Case scrut bndr ty alts) - = exprFVs scrut `mappend` shallowSelTypeFV ty `mappend` + = exprFVs scrut `mappend` deepSelTypeFV ty `mappend` addCoreBndrFV bndr (mapUnionFV alt_fvs alts) where alt_fvs (Alt _ bndrs rhs) = addCoreBndrsFV bndrs (exprFVs rhs) @@ -267,13 +286,13 @@ tickish_fvs _ = mempty --------- bndrTypeTyCoFVs :: Var -> SelectiveDFV --- Find the free variables of a binder. +-- Find the (deep) free variables of the type of a variable. -- In the case of ids, don't forget the multiplicity field! bndrTypeTyCoFVs var - = shallowSelTypeFV (varType var) `mappend` mult_fvs + = deepSelTypeFV (varType var) `mappend` mult_fvs where mult_fvs = case varMultMaybe var of - Just mult -> shallowSelTypeFV mult + Just mult -> deepSelTypeFV mult Nothing -> mempty dBndrTypeTyCoVars :: Var -> DTyCoVarSet @@ -286,11 +305,10 @@ bndrFreeVars id = assert (isId id) $ dBndrFreeVars id dBndrFreeVars :: Id -> DVarSet --- Shallow free vars dBndrFreeVars id = runFVSelective isLocalVar $ bndrFVs id bndrFVs :: Id -> SelectiveDFV --- Shallow free vars of types, rules, and inlining +-- Free vars of types, rules, and inlining bndrFVs id = assert (isId id) $ bndrTypeTyCoFVs id `mappend` bndrRuleAndUnfoldingFVs id @@ -593,7 +611,8 @@ Note [The FVAnn invariant] Invariant: a FVAnn, say S, is closed: That is: if v is in S, then freevars( v's type/kind ) is also in S -So FVAnn computes /deep/ free variables +So FVAnn computes /deep/ free variables, just like `exprFreeVars` does; +see Note [Free variables of an expression]. -} type FVAnn = DVarSet -- See Note [The FVAnn invariant] @@ -690,22 +709,15 @@ freeVars = go where go :: CoreExpr -> CoreExprWithFVs go (Var v) - | isLocalVar v = (aFreeVar v `unionDVarSet` ty_fvs `unionDVarSet` mult_vars, AnnVar v) - | otherwise = (emptyDVarSet, AnnVar v) - where - mult_vars = tyCoVarsOfTypeDSet (idMult v) - ty_fvs = dBndrTypeTyCoVars v - -- See Note [The FVAnn invariant] + | isLocalVar v = (aFreeVar v `unionDVarSet` dBndrTypeTyCoVars v, AnnVar v) + -- See Note [The FVAnn invariant] + | otherwise = (emptyDVarSet, AnnVar v) go (Lit lit) = (emptyDVarSet, AnnLit lit) go (Lam b body) - = ( b_fvs `unionDVarSet` (b `delBinderFV` body_fvs) - , AnnLam b body' ) + = ( b `delBinderFV` body_fvs, AnnLam b body' ) where body'@(body_fvs, _) = go body - b_ty = idType b - b_fvs = tyCoVarsOfTypeDSet b_ty - -- See Note [The FVAnn invariant] go (App fun arg) = ( freeVarsOf fun' `unionDVarSet` freeVarsOf arg' @@ -750,8 +762,7 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs = runFVSelective isLocalVar . tickish_fvs go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -2216,7 +2216,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs where rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - lhs_fvs = deepExprsFreeVarsDSet args -- Matching binds deeply + lhs_fvs = exprsFreeVarsDSet args -- Rule matching binds deeply, so compare + -- against the deep free vars rhs_fvs = exprFreeVarsDSet rhs is_bad_bndr :: Var -> Bool ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -3230,15 +3230,12 @@ etaBodyForJoinPoint need_args body ppr body $$ ppr (exprType body) body_ty = exprType body - in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty) - -- in_scope is a bit tricky. - -- - We are wrapping `body` in some value lambdas, so must not shadow - -- any free vars of `body` - -- - We are wrapping `body` in some type lambdas, so must not shadow any - -- tyvars in body_ty. Example: body is just a variable - -- (g :: forall (a::k). T k a -> Int) - -- We must not shadown that `k` when adding the /\a. So treat the free vars - -- of body_ty as in-scope. Showed up in #23026. + in_scope = mkInScopeSet (exprFreeVars body) + -- We are wrapping `body` in lambdas, so the in-scope set must contain the + -- /deep/ free vars of `body` (exprFreeVars returns deep free vars). + -- Why? See Note [No type-shadowing in Core]: if body is just a variable + -- (g :: forall (a::k). T k a -> Int) + -- we must not shadow that `k` when adding the /\a (#23026). -------------- freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2360,13 +2360,14 @@ new binding is abstracted. Several points worth noting poly_t = /\ a b -> (e1, e2) poly_x = /\ a -> fst (poly_t a *b*) -(AB2) We must do closeOverKinds. Example (#10934): +(AB2) We must abstract over kind variables too. Example (#10934): f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... Here we want to float 't', but we must remember to abstract over 'k' as well, even though it is not explicitly mentioned in the RHS, otherwise we get t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. + which is obviously bogus. `exprSomeFreeVars isTyVar` is deep, + so the kind variables are picked up with the rest. (AB3) We get the variables to abstract over by filtering down the the main_tvs for the original function, picking only ones @@ -2449,7 +2450,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body rhs' = GHC.Core.Subst.substExpr subst rhs -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') + tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') -- (AB2) abstract subst (CyclicSCC trpls) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids @@ -2478,14 +2479,12 @@ abstractFloats uf_opts top_lvl main_tvs floats body -- because it has a non-CoVar precondition | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var = -- 'var' is like 'x' in (AB4) - exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs + exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs -- (AB2) | otherwise = free_tvs choose_tvs free_tvs - = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3) - where - all_free_tvs = closeOverKinds free_tvs -- (AB2) + = filter (`elemVarSet` free_tvs) main_tvs -- (AB3) mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) mk_poly1 tvs_here var ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -60,6 +60,7 @@ import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( fromMaybe, orElse, catMaybes, isJust, isNothing ) import GHC.Data.FastString +import GHC.Data.Pair import GHC.Utils.Misc import GHC.Utils.Outputable @@ -2317,17 +2318,18 @@ they are constructor applications. Note [Free type variables of the qvar types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a call (f @a x True), that we want to specialise, what variables should -we quantify over. Clearly over 'a' and 'x', but what about any type variables -free in x's type? In fact we don't need to worry about them because (f @a) -can only be a well-typed application if its type is compatible with x, so any -variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take - (exprsFreeVars pats). - -BUT phantom type synonyms can mess this reasoning up, - eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. -See # 5458. Yuk. +we quantify over? Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them, because +argsToPats gives 'x' the type of the corresponding argument of f, instantiated +at the type arguments of the call pattern (and similarly for the fields of a +data constructor in the pattern). So any variables free in x's type are free +in (f @a), and hence either gathered via 'a' itself, or in scope at f's defn. +Hence we just take (exprsFreeVars pats). + +We do not use the type of the actual argument: it is not necessarily +syntactically equal to the type of f's argument, and so may mention other +variables, e.g. with a phantom type synonym (#5458) + x::T b with type T b = Int Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2337,7 +2339,7 @@ Wrinkles: * The list of argument patterns, cp_args, is no longer than the visible lambdas of the binding, ri_arg_occs. This is done via - the zipWithM in callToPat. + argsToPats in callToPat. * The list of argument patterns can certainly be shorter than the lambdas in the function definition (under-saturated). For example @@ -2602,8 +2604,9 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) callToPat env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScopeSet (sc_subst env) - ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) - -- This zip trims the args to be no longer than + ; arg_triples <- argsToPats env in_scope con_env (idType fn) args bndr_occs + (repeat NotMarkedStrict) + -- This trims the args to be no longer than -- the lambdas in the function definition (bndr_occs) -- Drop boring patterns from the end @@ -2631,14 +2634,11 @@ callToPat env bndr_occs call@(Call fn args con_env) -- See Note [Shadowing in SpecConstr] at the top (qktvs, qids) = partition isTyVar qvars - qvars' = scopedSort qktvs ++ map sanitise qids + qvars' = scopedSort qktvs ++ qids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = updateIdTypeAndMult expandTypeSynonyms id - -- See Note [Free type variables of the qvar types] - -- Check for bad coercion variables: see Note [SpecConstr and casts] ; let bad_covars = filter isCoVar qids ; warnPprTrace (not (null bad_covars)) @@ -2657,18 +2657,49 @@ callToPat env bndr_occs call@(Call fn args con_env) ; return (Just cp_res) } else return Nothing } - -- argToPat takes an actual argument, and returns an abstracted - -- version, consisting of just the "constructor skeleton" of the - -- argument, with non-constructor sub-expression replaced by new - -- placeholder variables. For example: - -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) +-- | Turn the arguments of an application into patterns using 'argToPat'. +-- +-- See Note [Free type variables of the qvar types]. +argsToPats :: ScEnv + -> InScopeSet -- ^ what's in scope at the function definition site + -> ValueEnv -- ^ 'ValueEnv' at the call site + -> Type -- ^ type of the head (function or data constructor) + -> [CoreArg] -- ^ arguments of the head + -> [ArgOcc] -- ^ occurrence info, one per argument; the result is trimmed to this length + -> [StrictnessMark] -- ^ strictness info, one per value argument + -> UniqSM [(Bool, CoreArg, [Id])] +argsToPats env in_scope val_env = go + where + go _ [] _ _ = return [] + go _ _ [] _ = return [] + go fun_ty (arg : args) (occ : occs) strs + = do { (pat, strs') <- case arg of + Type {} -> do { pat <- argToPat env in_scope val_env arg_ty arg occ NotMarkedStrict + ; return (pat, strs) } + _ | str : strs' <- strs + -> do { pat <- argToPat env in_scope val_env arg_ty arg occ str + ; return (pat, strs') } + | otherwise + -> pprPanic "argsToPats: more value arguments than strictness marks" + (ppr fun_ty $$ ppr (arg : args)) + ; pats <- go (applyTypeToArgs fun_ty [sndOf3 pat]) args occs strs' + ; return (pat : pats) } + where + arg_ty = piTyBinderType (fst (splitPiTy fun_ty)) +-- | 'argToPat' takes an actual argument, and returns an abstracted +-- version, consisting of just the "constructor skeleton" of the +-- argument, with non-constructor sub-expression replaced by new +-- placeholder variables. For example: +-- +-- > C a (D (f x) (g y)) ==> C p1 (D p2 p3) argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> StrictnessMark -- Tells us if this argument is a strict field of a data constructor + -> InScopeSet -- ^ what's in scope at the function definition site + -> ValueEnv -- ^ 'ValueEnv' at the call site + -> Type -- ^ type for this argument + -> CoreArg -- ^ A call arg (or component thereof) + -> ArgOcc -- ^ occurrence info for the argument + -> StrictnessMark -- ^ Tells us if this argument is a strict field of a data constructor -- See Note [SpecConstr and strict fields] -> UniqSM (Bool, CoreArg, [Id]) @@ -2682,25 +2713,26 @@ argToPat :: ScEnv -- lvl7 --> (True, lvl7) if lvl7 is bound -- somewhere further out -argToPat env in_scope val_env arg arg_occ arg_str +argToPat env in_scope val_env pat_ty arg arg_occ arg_str = do -- pprTraceM "argToPatIn" (ppr arg) - !res <- argToPat1 env in_scope val_env arg arg_occ arg_str + !res <- argToPat1 env in_scope val_env pat_ty arg arg_occ arg_str -- pprTraceM "argToPatOut" (ppr res) return res argToPat1 :: ScEnv -> InScopeSet -> ValueEnv + -> Type -> Expr CoreBndr -> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr CoreBndr, [Id]) -argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str +argToPat1 _env _in_scope _val_env _pat_ty arg@(Type {}) _arg_occ _arg_str = return (False, arg, []) -argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str - = argToPat env in_scope val_env arg arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Tick _ arg) arg_occ arg_str + = argToPat env in_scope val_env pat_ty arg arg_occ arg_str -- Note [Tick annotations in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes @@ -2708,8 +2740,8 @@ argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str -- ride roughshod over them all for now. --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules -argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str - = argToPat env in_scope val_env arg arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Let _ arg) arg_occ arg_str + = argToPat env in_scope val_env pat_ty arg arg_occ arg_str -- See Note [Matching lets] in "GHC.Core.Rules" -- Look through let expressions -- e.g. f (let v = rhs in (v,w)) @@ -2717,35 +2749,34 @@ argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str -- because the rule-matcher will look through the let. -- Casts: see Note [SpecConstr and casts] -argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) - = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str + = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env ty1 arg arg_occ arg_str ; if not interesting then - wildCardPat ty2 arg_str + wildCardPat pat_ty arg_str else return (interesting, Cast arg' co, strict_args) } where - ty2 = coercionRKind co + Pair ty1 ty2 = coercionKind co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat1 env in_scope val_env arg arg_occ _arg_str +argToPat1 env in_scope val_env _pat_ty arg arg_occ _arg_str | Just (ConVal _wf (DataAlt dc) args) <- isValue val_env arg -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2) , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - con_str, matched_str :: [StrictnessMark] + con_str :: [StrictnessMark] -- con_str corresponds 1-1 with the /value/ arguments - -- matched_str corresponds 1-1 with /all/ arguments con_str = dataConRepStrictness dc - matched_str = match_vals con_str rest_args + con_ty = applyTypeToArgs (dataConRepType dc) ty_args -- ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$ -- ppr dc $$ -- ppr con_str $$ -- ppr rest_args $$ -- ppr (map isTypeArg rest_args)) - ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str + ; prs <- argsToPats env in_scope val_env con_ty rest_args arg_occs con_str ; let args' = map sndOf3 prs :: [CoreArg] ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) ( ppr con_str $$ ppr rest_args $$ @@ -2760,17 +2791,6 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -> Just (repeat UnkOcc) | otherwise -> Nothing - match_vals bangs (arg:args) - | isTypeArg arg - = NotMarkedStrict : match_vals bangs args - | (b:bs) <- bangs - = b : match_vals bs args - match_vals [] [] = [] - match_vals as bs = - pprPanic "spec-constr:argToPat - Bangs don't match value arguments" - (text "arg:" <> ppr arg $$ - text "remaining args:" <> ppr as $$ - text "remaining bangs:" <> ppr bs) -- Check if the argument is a variable that -- (a) is used in an interesting way in the function body @@ -2779,7 +2799,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -- business of absence analysis, not SpecConstr.) -- (b) we know what its value is -- In that case it counts as "interesting" -argToPat1 env in_scope val_env (Var v) arg_occ arg_str +argToPat1 env in_scope val_env _pat_ty (Var v) arg_occ arg_str | sc_force env || specialisableArgOcc arg_occ -- (a) -- See Note [Forcing specialisation], point (FS3) , is_value -- (b) @@ -2836,8 +2856,8 @@ argToPat in_scope val_env arg arg_occ -- The default case: make a wild-card -- We use this for coercions too -argToPat1 _env _in_scope _val_env arg _arg_occ arg_str - = wildCardPat (exprType arg) arg_str +argToPat1 _env _in_scope _val_env pat_ty _arg _arg_occ arg_str + = wildCardPat pat_ty arg_str -- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -2111,7 +2111,7 @@ to push the cast back inside. It would be terrible if the cast defeated specialisation! Hence the use of collectBindersPushingCo. Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like @@ -2120,18 +2120,13 @@ with a=b=Int. Then the RULE will be something like where that `g` is really (Coercion (CoVar g)), since `g` is a coercion variable and can't appear as (Var g). -But both varToCoreExpr (when constructing the LHS args), and the -simplifier (when simplifying the LHS args), will transform to +When simplifying the LHS args, the simplifier may replace g with Refl: RULE forall (d:Num Int) (g :: F Int ~ F Int). f Int Int d <F Int> = f_spec -by replacing g with Refl. So now 'g' is unbound, which results in a later -crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a (Coercion Refl) - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. +So now 'g' is unbound on the LHS. That is OK: since g's type is +reflexive, the rule matcher instantiates it to Refl when the rule fires; +see Note [Unbound RULE binders] in GHC.Core.Rules. So specHeader simply +forall-quantifies 'g' like any other unspecialised binder. Note [Orphans and auto-generated rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2483,13 +2478,13 @@ instance Outputable SpecArg where ppr UnspecArg = text "UnspecArg" specArgsFVs :: InterestingVarFun -> [SpecArg] -> VarSet --- Find the shallow deep free vars of the SpecArgs that are not already in scope +-- Find the (deep) free vars of the SpecArgs specArgsFVs interesting args = runFVSelectiveSet interesting $ mapUnionFV get args where get :: SpecArg -> SelectiveDFV - get (SpecType ty) = shallowSelTypeFV ty + get (SpecType ty) = deepSelTypeFV ty get (SpecDict dx) = exprFVs dx get UnspecType = mempty get UnspecArg = mempty @@ -2652,15 +2647,12 @@ specHeader subst (bndr:bndrs) (UnspecArg : args) <- specHeader subst1 bndrs args ; let dummy_arg = varToCoreExpr bndr' - -- dummy_arg is usually just (Var bndr), - -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) - -- or even Coercion Refl (if t1=t2) - -- See Note [Evidence foralls] - bndrs = exprFreeIdsList dummy_arg + -- dummy_arg is (Var bndr'), or (Coercion (CoVarCo bndr')) + -- if bndr' is a coercion variable; see Note [Evidence foralls] ; pure ( useful, subst2 - , bndrs ++ rule_bs, dummy_arg : rule_es - , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } + , bndr' : rule_bs, dummy_arg : rule_es + , bndr' : spec_bs, dx, dummy_arg : spec_args ) } -- | Binds a dictionary argument to a fresh name, to preserve sharing ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -590,15 +590,15 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args ------------------ substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet -- Apply the substitution to the vars in the set, --- and take the shallow free vars of the result +-- and take the (deep) free vars of the result substDVarSet subst@(Subst _ _ tv_env cv_env) fvs = runFVSelective isLocalVar $ strictFoldDVarSet (mappend . do_one) mempty fvs where do_one :: Var -> SelectiveDFV do_one fv - | isTyVar fv = shallowSelTypeFV (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) - | isCoVar fv = shallowSelCoFV (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) + | isTyVar fv = deepSelTypeFV (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) + | isCoVar fv = deepSelCoFV (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) | otherwise = exprFVs (lookupIdSubst subst fv) ------------------ ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -26,8 +26,9 @@ module GHC.Core.TyCo.FVs coVarsOfCo, coVarsOfCos, coVarsOfCoDSet, coVarsOfCosDSet, - -- Shallow, deterministic, composable - shallowSelTypeFV, shallowSelCoFV, + -- Selective, deterministic, composable + shallowSelTypeFV, + deepSelTypeFV, deepSelCoFV, deepSelUnitFV, -- Almost devoid almostDevoidCoVarOfCo, @@ -50,7 +51,6 @@ module GHC.Core.TyCo.FVs occCheckExpand, -- * Closing over kinds - closeOverKindsDSet, closeOverKinds, ) where @@ -111,6 +111,9 @@ Examples: forall (a:(k:Type)). a {k} {k} (a:k->Type) (b:k) {a,b} {a,b,k} +Free variables of /terms/ (GHC.Core.FVs) are always deep; see +Note [Free variables of an expression] in GHC.Core.FVs. + Note [Computing deep free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -150,9 +153,10 @@ GHC.Types.Var.FV. At an occurrence of a variable (a::k) AND add on the free vars of its kind `k`. BUT in this latter step, start with an empty BoundVars set. -The "start with an empty BoundVars set" is implemented in `deepUnitFV`. It's -not /necessary/ to zap the BoundVars set, because of Invariant (NoTypeShadowing). -But it's a tiny bit more efficient because the BoundVars set is smaller. +The "start with an empty BoundVars set" is implemented in the `*UnitFV` +functions. It's not /necessary/ to zap the BoundVars set, because of +Invariant (NoTypeShadowing). But it's a tiny bit more efficient because the +BoundVars set is smaller. Side note: the free-variable binder would still work even without (NoTypeShadowing). Consider: @@ -256,39 +260,47 @@ deepCosFV :: [Coercion] -> TyCoFV (deepTypeFV, deepTypesFV, deepCoFV, deepCosFV) = foldTyCo deepTcvFolder deepTcvFolder :: TyCoFolder TyCoFV +deepTcvFolder = deepFolder (deepUnitFV fvs) fvs addBndrFV + where fvs = deepTypeFV . varType + +deepFolder :: Monoid fv + => (TyCoVar -> fv) -- ^ an occurrence of a variable + -> (TyCoVar -> fv) -- ^ the free variables of a variable's type + -> (TyCoVar -> fv -> fv) -- ^ go under a binder + -> TyCoFolder fv +-- A folder computing deep free variables; the occurrence function is one of +-- the `*UnitFV` functions. See Note [Computing deep free variables]. +-- -- It's important that we use a one-shot EndoOS, to ensure that all -- the free-variable finders are eta-expanded. Lacking the one-shot-ness -- led to some big slow downs. See Note [The one-shot state monad trick] -- in GHC.Utils.Monad -deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_lit = const mempty - , tcf_tycobinder = addBndrFV } - where - do_tcv :: TyVar -> TyCoFV - do_tcv = deepUnitFV deepTypeFV - - do_hole :: CoercionHole -> TyCoFV - do_hole hole = deepTypeFV (varType (coHoleCoVar hole)) +{-# INLINE deepFolder #-} +deepFolder occ fvs_of_type add_bndr + = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = occ, tcf_covar = occ + , tcf_hole = fvs_of_type . coHoleCoVar -- We don't collect the CoercionHole itself, but we /do/ -- need to collect the free variables of its /kind/ -- See Note [CoercionHoles and coercion free variables] + , tcf_lit = const mempty + , tcf_tycobinder = add_bndr } -deepUnitFV :: (Type -> TyCoFV) -> TyCoVar -> TyCoFV --- Deal with a single TyCoVar --- Takes a function to find free vars of the kind +deepUnitFV :: (TyCoVar -> TyCoFV) -- ^ the free variables of a variable's type + -> TyCoVar -> TyCoFV +-- Deal with an occurrence of a single 'TyCoVar' -- See Note [Computing deep free variables] -{-# INLINE deepUnitFV #-} -- INLINE to specialise on fvs_of_kind -deepUnitFV fvs_of_kind +{-# INLINE deepUnitFV #-} -- INLINE to specialise on fvs_of_type +deepUnitFV fvs_of_type = \v -> MkFV (\bvs -> EndoOS (do_it bvs v)) where do_it :: BoundVars -> TyCoVar -> TyCoVarSet -> TyCoVarSet do_it bvs v acc | v `elemVarSet` bvs = acc | v `elemVarSet` acc = acc - | otherwise = runFVAcc (fvs_of_kind (varType v)) acc + | otherwise = runFVAcc (fvs_of_type v) acc `extendVarSet` v - -- Left-to-right: add the kind variables to the - -- accumulator before v itself + -- Left-to-right: add the kind variables to the + -- accumulator before v itself {- ********************************************************************* * * @@ -389,31 +401,22 @@ deepDetCoFV :: Coercion -> DTyCoFV (deepDetTypeFV, deepDetTypesFV, deepDetCoFV, _) = foldTyCo deepDetTcvFolder deepDetTcvFolder :: TyCoFolder DTyCoFV --- This one returns a /deterministic/ list --- See `deepTcvFolder` for the general pattern -deepDetTcvFolder - = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_lit = const mempty - , tcf_tycobinder = addBndrFV } - where - do_tcv = deepDetUnitFV deepDetTypeFV - do_hole hole = deepDetTypeFV (varType (coHoleCoVar hole)) - -deepDetUnitFV :: (Type -> DTyCoFV) -> TyCoVar -> DTyCoFV --- Deal with a single TyCoVar --- Takes a function to find free vars of the kind --- See Note [Computing deep free variables] -deepDetUnitFV fvs_of_kind v - = MkFV (\bvs -> EndoOS (do_it bvs)) +-- This one returns a /deterministic/ set +deepDetTcvFolder = deepFolder (deepDetUnitFV fvs) fvs addBndrFV + where fvs = deepDetTypeFV . varType + +deepDetUnitFV :: (TyCoVar -> DTyCoFV) -- ^ the free variables of a variable's type + -> TyCoVar -> DTyCoFV +-- Deterministic version of 'deepUnitFV' +{-# INLINE deepDetUnitFV #-} -- INLINE to specialise on fvs_of_type +deepDetUnitFV fvs_of_type + = \v -> MkFV (\bvs -> EndoOS (do_it bvs v)) where - do_it :: BoundVars -> DTyCoVarSet -> DTyCoVarSet - do_it bvs acc | v `elemVarSet` bvs = acc - | v `elemDVarSet` acc = acc - | otherwise = runFVAcc (fvs_of_kind (varType v)) acc - `extendDVarSet` v - -- Left-to-right: add the kind variables to the - -- accumulator before v itself + do_it :: BoundVars -> TyCoVar -> DTyCoVarSet -> DTyCoVarSet + do_it bvs v acc | v `elemVarSet` bvs = acc + | v `elemDVarSet` acc = acc + | otherwise = runFVAcc (fvs_of_type v) acc + `extendDVarSet` v {- ********************************************************************* * * @@ -430,30 +433,61 @@ someTyCoVarsOfTypes interesting = runFVSelectiveList interesting . mapUnionFV shallowSelTypeFV shallowSelTypeFV :: Type -> SelectiveDFV -shallowSelCoFV :: Coercion -> SelectiveDFV -- Returns shallow free vars -- See Note [Shallow and deep free variables] -(shallowSelTypeFV, _, shallowSelCoFV, _) = foldTyCo selectiveTcvFolder +(shallowSelTypeFV, _, _, _) = foldTyCo selectiveTcvFolder selectiveTcvFolder :: TyCoFolder SelectiveDFV -- This one takes an `InterestingVarFun`, and returns shallow free vars -- See `shallowTcvFolder` for the general pattern selectiveTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] - , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_tyvar = shallowSelUnitFV, tcf_covar = shallowSelUnitFV , tcf_hole = do_hole, tcf_lit = const mempty , tcf_tycobinder = addBndrSelectiveFV } where - do_tcv v = MkFV (\env -> EndoOS (do_it env)) - where - do_it (bvs,is_interesting) acc - | v `elemVarSet` bvs = acc -- First exclude bound variables - | not (is_interesting v) = acc -- The "selective" bit - | v `elemDVarSet` acc = acc - | otherwise = acc `extendDVarSet` v - do_hole hole = shallowSelTypeFV (varType (coHoleCoVar hole)) +shallowSelUnitFV :: TyCoVar -> SelectiveDFV +shallowSelUnitFV v = MkFV (\env -> EndoOS (do_it env)) + where + do_it (bvs,is_interesting) acc + | v `elemVarSet` bvs = acc -- First exclude bound variables + | not (is_interesting v) = acc -- The "selective" bit + | v `elemDVarSet` acc = acc + | otherwise = acc `extendDVarSet` v + + +{- ********************************************************************* +* * + Selective, deep, deterministic free vars +* * +********************************************************************* -} + +deepSelTypeFV :: Type -> SelectiveDFV +deepSelCoFV :: Coercion -> SelectiveDFV +-- Returns deep free vars, selectively +-- See Note [Shallow and deep free variables] +(deepSelTypeFV, _, deepSelCoFV, _) = foldTyCo deepSelectiveTcvFolder + +deepSelectiveTcvFolder :: TyCoFolder SelectiveDFV +deepSelectiveTcvFolder = deepFolder (deepSelUnitFV fvs) fvs addBndrSelectiveFV + where fvs = deepSelTypeFV . varType + +deepSelUnitFV :: (TyCoVar -> SelectiveDFV) -- ^ the free variables of a variable's type + -> TyCoVar -> SelectiveDFV +-- ^ Selective version of 'deepUnitFV'. +{-# INLINE deepSelUnitFV #-} -- INLINE to specialise on fvs_of_type +deepSelUnitFV fvs_of_type + = \v -> MkFV (\env -> EndoOS (do_it env v)) + where + do_it (bvs,is_interesting) v acc + | v `elemVarSet` bvs = acc + | not (is_interesting v) = acc + | v `elemDVarSet` acc = acc + | otherwise = runFVSelectiveAcc is_interesting (fvs_of_type v) acc + `extendDVarSet` v + {- ********************************************************************* * * @@ -508,7 +542,7 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView -- the tyvar won't end up in the accumulator, so -- we'd look repeatedly. Blargh. - do_covar = deepUnitFV deepCoVarTypeFV + do_covar = deepUnitFV (deepCoVarTypeFV . varType) do_hole hole = do_covar (coHoleCoVar hole) -- We /do/ treat a CoercionHole as a free variable @@ -540,7 +574,7 @@ deepDetCoVarFolder = TyCoFolder { tcf_view = noView do_tyvar _ = mempty do_covar :: CoVar -> DCoVarFV - do_covar = deepDetUnitFV det_ty + do_covar = deepDetUnitFV (det_ty . varType) do_hole hole = do_covar (coHoleCoVar hole) @@ -558,13 +592,6 @@ closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs where do_one v = runFVAcc (deepTypeFV (varType v)) --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet vs = nonDetStrictFoldDVarSet do_one vs vs - where - do_one v = runFVAcc (deepDetTypeFV (varType v)) - {- %************************************************************************ @@ -779,7 +806,7 @@ inj_vars_of_type :: Bool -> Type -> TyCoFV inj_vars_of_type look_under_tfs = go where go ty | Just ty' <- rewriterView ty = go ty' - go (TyVarTy v) = deepUnitFV go v + go (TyVarTy v) = deepUnitFV (go . varType) v go (AppTy f a) = go f `mappend` go a go (FunTy _ w ty1 ty2) = go w `mappend` go ty1 `mappend` go ty2 go (TyConApp tc tys) = go_tc tc tys ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -168,7 +168,6 @@ module GHC.Core.Type ( typeSize, occCheckExpand, -- ** Closing over kinds - closeOverKindsDSet, closeOverKinds, -- * Forcing evaluation of types ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -92,6 +92,7 @@ import GHC.Types.Id.Info import GHC.Types.InlinePragma ( alwaysInlinePragma, competesWith ) import GHC.Types.ForeignStubs import GHC.Types.Avail +import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -479,7 +480,7 @@ dsWarnRuleShadowing fn_id where bndrs_set = mkVarSet bndrs arg_ids = filterOut (`elemVarSet` bndrs_set) $ - exprsSomeFreeVarsList isId args + exprsSomeFreeVarsList isNonCoVarId args check check_rules_too lhs_id | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1014,8 +1014,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call is_local v = v `elemVarSet` locals -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas] - -- We have to do closeOverKinds beccause exprsSomeFreeVars is shallow - rule_bndrs = scopedSort $ dVarSetElems $ closeOverKindsDSet $ + rule_bndrs = scopedSort $ dVarSetElems $ exprsSomeFreeVarsDSet is_local rule_lhs_args -- getRenamings: (S3) of Note [Desugaring new-form SPECIALISE pragmas] ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -183,7 +183,7 @@ module GHC.Tc.Utils.TcType ( coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, tyCoVarsOfTypeList, tyCoVarsOfTypesList, noFreeVarsOfType, ===================================== compiler/GHC/Types/Var/FV.hs ===================================== @@ -6,7 +6,7 @@ module GHC.Types.Var.FV ( BoundVars, VarSetFV, DVarSetFV, SelectiveDFV, TyCoFV, DTyCoFV, runFVTop, runFVAcc, runTyCoVars, runTyCoVarsDSet, - runFVSelective, runFVSelectiveList, runFVSelectiveSet, + runFVSelective, runFVSelectiveAcc, runFVSelectiveList, runFVSelectiveSet, InterestingVarFun, updEnvFV, addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV, @@ -225,8 +225,11 @@ runTyCoVarsDSet :: DTyCoFV -> DTyCoVarSet runTyCoVarsDSet f = runFVAcc f emptyDVarSet runFVSelective :: InterestingVarFun -> SelectiveDFV -> DVarSet -runFVSelective interesting f - = runEndoOS (runFV f (emptyVarSet, interesting)) emptyDVarSet +runFVSelective interesting f = runFVSelectiveAcc interesting f emptyDVarSet + +runFVSelectiveAcc :: InterestingVarFun -> SelectiveDFV -> DVarSet -> DVarSet +-- Add the interesting free variables to the accumulator +runFVSelectiveAcc interesting f = runEndoOS (runFV f (emptyVarSet, interesting)) runFVSelectiveList :: InterestingVarFun -> SelectiveDFV -> [Var] runFVSelectiveList interesting f = dVarSetElems (runFVSelective interesting f) ===================================== testsuite/tests/simplCore/should_compile/T27936.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, ViewPatterns, RankNTypes #-} +{-# OPTIONS_GHC -fno-opt-coercion #-} +module T27936 where + +data G a where + MkG :: G Int + +f :: G a -> a -> Int -> Int +f MkG v (((\x -> (v + 1, x)) :: forall b. b -> (Int, b)) -> (y, _)) = y ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -627,3 +627,5 @@ test('T27749', compile, ['-O -g3 -ddump-simpl -dsuppress-uniques']) test('T27629', only_ways(['optasm']), makefile_test, ['T27629']) + +test('T27936', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/033ba59cbe5e70dea06fb50517d4c78… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/033ba59cbe5e70dea06fb50517d4c78… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] EPA: Start using vocurly as basis for AnnListLayout
by Marge Bot (＠marge-bot) 15 Oct '26

15 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f34c79ee by Alan Zimmerman at 2026-10-15T04:54:47-04:00 EPA: Start using vocurly as basis for AnnListLayout For the existing cases that populate AnnList. This uses AnnListBraces when braces are explicitly supplied, and AnnListLayout when vocurly is used The change also shows up AnnList usages that can never capture layout, these are cleared up later. - - - - - 2 changed files: - compiler/GHC/Parser.y - testsuite/tests/parser/should_compile/DumpSemis.stderr Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -1797,10 +1797,10 @@ cvars1 :: { [RecordPatSynField GhcPs] } where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } + AnnList AnnListBraces (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) } + AnnList (AnnListLayout (glR $3)) ListNone (sndOf3 $ unLoc $3))) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1936,7 +1936,7 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } | {- empty -} { noLoc (noAnn, [],nilOL) } decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) + : '{' decls '}' { sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } | vocurly decls close { sL1 $2 (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } @@ -1952,7 +1952,7 @@ binds :: { Located (HsLocalBinds GhcPs) } ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList la p s) cs, noEpTok) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (AnnListLayout$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc $ HsIPBinds (EpAnn (glR $1) (AnnList (AnnListLayout $ glR $2) ListNone []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } @@ -3543,12 +3543,12 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), - (AnnList (AnnListLayout $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } + (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsA' (L (getLoc $2) (reverse (snd $ unLoc $2), (AnnList (AnnListLayout $ glR $2) ListNone (fst $ unLoc $2)))) } - | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListNoLayout (ListBraces (epTok $1) (epTok $2)) []))) } - | vocurly close { return $ noLocA ([], noAnn) } + | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $2)) []))) } + | vocurly close { return $ noLocA ([], AnnList (AnnListLayout $ glR $1) ListNone []) } alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } : alts1(PATS) { $1 >>= \ $1 -> return $ @@ -3657,7 +3657,7 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsA' (sLL $1 $> (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) + amsA' (sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) , sL1 $2 $ reverse $ snd $ unLoc $2))} | vocurly stmts close { $2 >>= \ $2 -> amsA' (L (stmtsLoc $2) (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -364,8 +364,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:11:8-13 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:11:6 })) (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) @@ -627,8 +626,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:16:3 })) (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) @@ -880,8 +878,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:22:12-28 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:22:10 })) (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) @@ -1936,8 +1933,7 @@ (EpAnn (EpaSpan { DumpSemis.hs:34:13-31 }) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:34:18-30 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:34:13 })) (EpTok (EpaSpan { DumpSemis.hs:34:31 }))) @@ -2333,8 +2329,7 @@ ((,) (FromSource) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(38,6)-(43,13) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:38:4 })) (EpTok (EpaSpan { DumpSemis.hs:44:4 }))) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f34c79ee8e394b59dd9bc0c93078a0a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f34c79ee8e394b59dd9bc0c93078a0a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andrea/async-rpc] close Handles when done with Pipe
by Andrea Vezzosi (＠trac-Saizan) 15 Oct '26

15 Oct '26

Andrea Vezzosi pushed to branch wip/andrea/async-rpc at Glasgow Haskell Compiler / GHC Commits: 14f03672 by Andrea Vezzosi at 2026-10-15T10:02:38+02:00 close Handles when done with Pipe - - - - - 3 changed files: - compiler/GHC/Runtime/Interpreter.hs - libraries/ghci/GHCi/Message/Async.hs - libraries/ghci/GHCi/Server.hs Changes: ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -654,6 +654,8 @@ stopInterp interp = case interpInstance interp of if isJust ex then pure () else sendMessage i Shutdown + -- We asked the server to shutdown, so we will also shutdown any communication. + closePipe (interpPipe (instProcess i)) pure InterpPending -- ----------------------------------------------------------------------------- ===================================== libraries/ghci/GHCi/Message/Async.hs ===================================== @@ -70,8 +70,13 @@ data Pipe = Pipe , pipeLeftovers :: !(IORef (Maybe ByteString)) , pipeLock :: !(MVar ()) -- ^ Lock to prevent concurrent writes to the stream , pipeAsyncMngr :: !AsyncManager + , pipeCloseRead :: !(IO ()) + -- ^ closes read end of the pipe + , pipeCloseWrite :: !(IO ()) + -- ^ closes write end of the pipe , pipeIsClosed :: !(TVar Bool) - -- ^ After the pipe is closed, requests can no longer be received nor sent + -- ^ After the pipe is closed, messages can no longer be received from the + -- other end, but the 'AsyncManager' queues might not be empty yet. } -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. @@ -82,12 +87,17 @@ mkPipeFromHandles pipeRead pipeWrite = do putAll b = do B.hPutBuilder pipeWrite b hFlush pipeWrite - mkPipeFromContinuations getSome putAll + mkPipeFromContinuations getSome putAll (hClose pipeRead) (hClose pipeWrite) -- | Make a 'Pipe' from a reader function and a writer function. --- The pipe should be closed with 'closePipe'. -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe -mkPipeFromContinuations getSome putAll = mdo +-- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'. +mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) + -> IO () + -- ^ pipeCloseRead + -> IO () + -- ^ pipeCloseWrite + -> IO Pipe +mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo pipeLeftovers <- newIORef Nothing pipeLock <- newMVar () pipeIsClosed <- newTVarIO False @@ -96,18 +106,16 @@ mkPipeFromContinuations getSome putAll = mdo let p = Pipe { .. } pure p --- | Cleanly close our end of the Pipe, terminating the async manager's --- drain-read-end thread. Calling 'closePipe' on an already closed pipe is a no-op. +-- | Cleanly close our ends of the Pipe, terminating the async manager's +-- drain-read-end thread. Also calls 'pipeCloseRead' and 'pipeCloseWrite', in that order. -- --- If the pipe was created using 'mkPipeFromHandles', the handles must only by --- closed after calling 'closePipe'. +-- If the pipe was created using 'mkPipeFromHandles', the handles are also closed. -- -- The requests we've sent that are pending are all canceled with -- 'PipeClosedException' by ourselves. -- --- The remote process does not necessarily detect that this end of the pipe was --- closed, but it must handle cleanly and clean up after exceptions caused from --- it such as a handle being closed. +-- No special notification is sent to the remote process, a message to that +-- effect should be sent ahead of time if one is needed (see 'Shutdown'). closePipe :: Pipe -> IO () closePipe Pipe{..} = do @@ -119,6 +127,8 @@ closePipe Pipe{..} = do -- pending request with 'PipeClosedException'. throwTo (asyncDrainTid pipeAsyncMngr) PipeClosedException + pipeCloseWrite + -- | We've closed the pipe on our end and we terminate all pending requests with this. data PipeClosedException = PipeClosedException deriving Show instance Exception PipeClosedException @@ -369,7 +379,7 @@ newAsyncManager pipe = do -- 'Pipe' and a thread draining the read end of the interpreter's 'Pipe', since -- both processes construct a 'Pipe' and send and receive messages drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO () -drainPipe p unmask = catch (unmask loop) replyToPendings where +drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings where loop = do readPipe p >>= \case -- Receive a reply to a pending notification ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -78,6 +78,9 @@ servWithCustom verbose hook pipe restore customHandler = newIORef False >>= loop RunModFinalizers ii st qrefs -> wrapRunTH ii $ runModFinalizerRefs pipe ii st qrefs _other -> run msg >>= reply + -- closePipe here will wait until every active pipeWrite pipe exits, but + -- they should never block for long, as the host process is either reading + -- or has called pipeCloseRead. isDone <- readIORef doneRef if isDone then closePipe pipe else loop doneRef @@ -184,7 +187,7 @@ defaultServerWithCustom customHandler = do #if defined(wasm32_HOST_ARCH) -- See Note [wasm ghci signal handlers] for details installSignalHandlers $ js_register_signal_handler cb_sig - pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) + pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) (pure ()) (pure ()) #else when verbose $ printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14f03672c3eeadcdea77560aeae3b23… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14f03672c3eeadcdea77560aeae3b23… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/andrea/async-rpc
by Andrea Vezzosi (＠trac-Saizan) 15 Oct '26

15 Oct '26

Andrea Vezzosi pushed new branch wip/andrea/async-rpc at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andrea/async-rpc You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0