- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Do not leave standard file descriptors free at startup (#24450)
by Marge Bot (＠marge-bot) 06 Oct '26

06 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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> - - - - - 5 changed files: - + changelog.d/24450 - rts/RtsStartup.c - + testsuite/tests/rts/T24450.hs - + testsuite/tests/rts/T24450.stderr - testsuite/tests/rts/all.T Changes: ===================================== changelog.d/24450 ===================================== @@ -0,0 +1,14 @@ +section: rts +synopsis: + Fix a hang when a program is started with a standard file descriptor closed +description: + A process started with stdout or stderr closed -- ``prog >&-`` from a shell + does exactly that -- left that descriptor number free for the runtime to + take for its own use. The ``Handle`` for the stream, built later when the + program first wrote to it, then took over a descriptor belonging to the + runtime: the program wrote its output into the runtime's own plumbing and + hung, with no error reported anywhere. The runtime now opens ``/dev/null`` + onto whichever of the descriptors 0, 1 and 2 are closed when it starts, so + such a stream is connected to ``/dev/null`` instead. +mrs: !16710 +issues: #24450 ===================================== rts/RtsStartup.c ===================================== @@ -69,6 +69,10 @@ #if defined(HAVE_LOCALE_H) #include <locale.h> #endif +#if !defined(mingw32_HOST_OS) +#include <errno.h> +#include <fcntl.h> +#endif // Count of how many outstanding hs_init()s there have been. static StgWord hs_init_count = 0; @@ -81,6 +85,10 @@ static int64_t __codePage = -1; static void flushStdHandles(void); +#if !defined(mingw32_HOST_OS) +static void sanitiseStandardFds(void); +#endif + /* ----------------------------------------------------------------------------- Initialise floating point unit on x86 (currently disabled; See Note [x86 Floating point precision] in compiler/GHC/CmmToAsm/X86/Instr.hs) @@ -238,6 +246,82 @@ hs_init_with_rtsopts(int *argc, char **argv[]) void init_ghc_hs_iface(void); +#if !defined(mingw32_HOST_OS) +/* See Note [Standard file descriptors must be open]. */ +static void sanitiseStandardFds(void) +{ + // The access mode each descriptor would have had, had the process been + // started with it open. + static const int access_mode[3] = { O_RDONLY, O_WRONLY, O_WRONLY }; + + for (int fd = 0; fd <= 2; fd++) { + if (fcntl(fd, F_GETFD) != -1 || errno != EBADF) { + continue; // already open + } + + int nullfd; + do { + nullfd = open("/dev/null", access_mode[fd]); + } while (nullfd == -1 && errno == EINTR); + + if (nullfd == -1) { + // No /dev/null to be had. There is nothing better to do than + // carry on; the hazard the Note describes is then still there, + // but refusing to start would be worse. + return; + } + if (nullfd != fd) { + // open() hands out the lowest free descriptor, so this cannot + // happen unless something in this process is opening descriptors + // concurrently. Do not shuffle its descriptor around. + close(nullfd); + return; + } + } +} + +/* + * Note [Standard file descriptors must be open] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A process may be started with any of file descriptors 0, 1 and 2 closed -- + * from a shell, `prog >&-` does exactly that. Nothing then reserves those + * numbers, and open(), pipe() and socket() hand out the lowest free + * descriptor, so the next descriptor the runtime creates for itself takes one + * of them: the ticker's pipe, or a capability's IO manager control pipe. + * + * Nothing warns anybody. 'GHC.Internal.IO.StdHandles.stdout' is a CAF, so it + * is built the first time the program writes to stdout, which is long after + * that has happened, and it builds a 'Handle' over descriptor 1 -- which now + * belongs to the runtime. The program then writes its output into the + * runtime's own plumbing, and at exit closes it. + * + * What this looks like from the outside is a hang, because the descriptor the + * Handle has taken over is the read end of a pipe. It is a perfectly good + * descriptor, so nothing reports an error: poll() for POLLOUT on it simply + * never says yes, epoll_ctl() accepts a registration for it, and the thread + * waiting to write blocks for ever. See #24450, where this is `prog >&-` + * hanging after main has finished. + * + * Closing those descriptors is legal, so the runtime cannot refuse them; and + * moving only the descriptors the runtime opens would not help, since the + * first file the program itself opens would land on the free number instead. + * The fix is to leave no free number: open /dev/null onto whichever of 0, 1 + * and 2 are closed, before the runtime creates any descriptor of its own. + * Other runtimes do the same, and for the same reason. + * + * A program run this way therefore finds stdout connected to /dev/null rather + * than failing with EBADF on the first write. That is the price of the fix, + * and it is the behaviour such a program would get from most other language + * runtimes. + * + * Each substitute is opened for the access the descriptor would normally have: + * read-only for 0, write-only for 1 and 2. Opening all three for both would + * make the substitute something a real stdin or stdout is not, and writing to + * 'stdin' or reading from 'stdout' would then quietly succeed instead of + * failing with EBADF. + */ +#endif + void hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) { @@ -252,6 +336,12 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) stg_exit(1); } +#if !defined(mingw32_HOST_OS) + /* Before anything here opens a file descriptor of its own. + See Note [Standard file descriptors must be open]. */ + sanitiseStandardFds(); +#endif + #if defined(wasm32_HOST_ARCH) char *pwd = getenv("PWD"); if (pwd != NULL) { ===================================== testsuite/tests/rts/T24450.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- A process may be started with stdout closed -- `prog >&-` from a shell does +-- exactly that. Nothing then reserves descriptor 1, so the next descriptor +-- the runtime opens for itself takes it, and the 'Handle' for stdout, built +-- later when the program first writes, takes over a descriptor belonging to +-- the runtime. The write then goes into the runtime's own plumbing, and what +-- this looks like from the outside is a hang. See #24450 and +-- Note [Standard file descriptors must be open] in rts/RtsStartup.c. +-- +-- This test is run with its stdin and stdout closed, so what it has to say +-- goes to stderr. The four writes are the reproducer from the ticket and must +-- simply finish. The lines after them are what tell the two outcomes apart: +-- the descriptors the runtime opens for itself are pipes, so finding a pipe on +-- descriptor 0 or 1 means it was handed to the runtime. +module Main (main) where + +import Control.Exception (IOException, try) +import System.IO +import System.Posix.Files (getFdStatus, isCharacterDevice, isNamedPipe) +import System.Posix.Types (Fd (..)) + +main :: IO () +main = do + hPutChar stderr 'A' -- unbuffered + hPutChar stdout 'X' -- buffered; this is the one that used to hang + hPutChar stderr 'Z' -- unbuffered + hPutChar stderr '\n' -- unbuffered + mapM_ (\fd -> hPutStrLn stderr =<< describeFd fd) [0, 1] + +describeFd :: Fd -> IO String +describeFd fd = do + r <- try (getFdStatus fd) + return $ "fd " ++ show fd ++ ": " ++ case r of + Left (_ :: IOException) -> "closed" + Right st + -- What the fix arranges: /dev/null, opened onto the free number + -- before the runtime could take it. + | isCharacterDevice st -> "character device" + -- What #24450 is: the runtime's ticker or control pipe. + | isNamedPipe st -> "pipe" + | otherwise -> "something else" ===================================== testsuite/tests/rts/T24450.stderr ===================================== @@ -0,0 +1,3 @@ +AZ +fd 0: character device +fd 1: character device ===================================== testsuite/tests/rts/all.T ===================================== @@ -408,6 +408,18 @@ test('T10590', [ ignore_stderr , req_process ], compile_and_run, ['']) +# Run with stdin and stdout closed -- that is what leaves those descriptors +# free for the runtime to take, which is the whole of #24450. What the test +# has to say therefore goes to stderr and is checked against T24450.stderr. +test('T24450', + [ when(opsys('mingw32'), skip) # POSIX only + , js_skip # JS backend has its own runtime + # The wrapper below would close the stdout of the wasm runtime rather + # than that of the program running under it, which tests nothing. + , when(arch('wasm32'), skip) + , cmd_wrapper(lambda c: c + ' <&- >&-') + ], compile_and_run, ['']) + # 20000 was easily enough to trigger the bug with 7.10 test('T10904', [ extra_run_opts('20000'), req_c ], compile_and_run, ['T10904lib.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d49ed42d8ec1ad92737fa338571aad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d49ed42d8ec1ad92737fa338571aad… 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] changelog: Repair the sentence describing #27477
by Marge Bot (＠marge-bot) 06 Oct '26

06 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 1 changed file: - changelog.d/fix-parallel-gc-selector-race-27477 Changes: ===================================== changelog.d/fix-parallel-gc-selector-race-27477 ===================================== @@ -1,7 +1,7 @@ section: rts synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap description: - On weakly-ordered architectures such as AArch64 programs using + On weakly-ordered architectures such as AArch64, programs could crash during parallel garbage collection (segmentation fault or ``internal error: eval_thunk_selector: strange selectee <n>``) or continue running with silently corrupted heap data, due to a missing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65bcf9e9116c3a8170d3a7e568f2a35… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65bcf9e9116c3a8170d3a7e568f2a35… 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/substitution-via-mapper] Refactor type and coercion substitution
by Simon Peyton Jones (＠simonpj) 06 Oct '26

06 Oct '26

Simon Peyton Jones pushed to branch wip/substitution-via-mapper at Glasgow Haskell Compiler / GHC Commits: 7f47443d by Simon Peyton Jones at 2026-10-07T00:33:37+01: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 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. Refactoring 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` - - - - - 57 changed files: - compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.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/Type.hs - compiler/GHC/Core/Type.hs-boot - compiler/GHC/Core/Unify.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToIface.hs-boot - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Iface/Type.hs-boot - compiler/GHC/IfaceToCore.hs - compiler/GHC/Stg/EnforceEpt/TagSig.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Cpr.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Name/Env.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Map.hs - compiler/GHC/Types/Unique/Set.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Types/Var.hs-boot - compiler/GHC/Types/Var/Set.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - + compiler/GHC/Utils/StrictIdentity.hs - compiler/Language/Haskell/Syntax/Specificity.hs - compiler/ghc.cabal.in - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f47443d93c46d8ebb20897a2c944c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f47443d93c46d8ebb20897a2c944c7… 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/marge_bot_batch_merge_job] 2 commits: Do not leave standard file descriptors free at startup (#24450)
by Marge Bot (＠marge-bot) 06 Oct '26

06 Oct '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cbfbecb6 by Kazu Yamamoto at 2026-10-06T15:16:47-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> - - - - - f20e7d94 by Simon Jakobi at 2026-10-06T15:16:48-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 - - - - - 6 changed files: - + changelog.d/24450 - changelog.d/fix-parallel-gc-selector-race-27477 - rts/RtsStartup.c - + testsuite/tests/rts/T24450.hs - + testsuite/tests/rts/T24450.stderr - testsuite/tests/rts/all.T Changes: ===================================== changelog.d/24450 ===================================== @@ -0,0 +1,14 @@ +section: rts +synopsis: + Fix a hang when a program is started with a standard file descriptor closed +description: + A process started with stdout or stderr closed -- ``prog >&-`` from a shell + does exactly that -- left that descriptor number free for the runtime to + take for its own use. The ``Handle`` for the stream, built later when the + program first wrote to it, then took over a descriptor belonging to the + runtime: the program wrote its output into the runtime's own plumbing and + hung, with no error reported anywhere. The runtime now opens ``/dev/null`` + onto whichever of the descriptors 0, 1 and 2 are closed when it starts, so + such a stream is connected to ``/dev/null`` instead. +mrs: !16710 +issues: #24450 ===================================== changelog.d/fix-parallel-gc-selector-race-27477 ===================================== @@ -1,7 +1,7 @@ section: rts synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap description: - On weakly-ordered architectures such as AArch64 programs using + On weakly-ordered architectures such as AArch64, programs could crash during parallel garbage collection (segmentation fault or ``internal error: eval_thunk_selector: strange selectee <n>``) or continue running with silently corrupted heap data, due to a missing ===================================== rts/RtsStartup.c ===================================== @@ -69,6 +69,10 @@ #if defined(HAVE_LOCALE_H) #include <locale.h> #endif +#if !defined(mingw32_HOST_OS) +#include <errno.h> +#include <fcntl.h> +#endif // Count of how many outstanding hs_init()s there have been. static StgWord hs_init_count = 0; @@ -81,6 +85,10 @@ static int64_t __codePage = -1; static void flushStdHandles(void); +#if !defined(mingw32_HOST_OS) +static void sanitiseStandardFds(void); +#endif + /* ----------------------------------------------------------------------------- Initialise floating point unit on x86 (currently disabled; See Note [x86 Floating point precision] in compiler/GHC/CmmToAsm/X86/Instr.hs) @@ -238,6 +246,82 @@ hs_init_with_rtsopts(int *argc, char **argv[]) void init_ghc_hs_iface(void); +#if !defined(mingw32_HOST_OS) +/* See Note [Standard file descriptors must be open]. */ +static void sanitiseStandardFds(void) +{ + // The access mode each descriptor would have had, had the process been + // started with it open. + static const int access_mode[3] = { O_RDONLY, O_WRONLY, O_WRONLY }; + + for (int fd = 0; fd <= 2; fd++) { + if (fcntl(fd, F_GETFD) != -1 || errno != EBADF) { + continue; // already open + } + + int nullfd; + do { + nullfd = open("/dev/null", access_mode[fd]); + } while (nullfd == -1 && errno == EINTR); + + if (nullfd == -1) { + // No /dev/null to be had. There is nothing better to do than + // carry on; the hazard the Note describes is then still there, + // but refusing to start would be worse. + return; + } + if (nullfd != fd) { + // open() hands out the lowest free descriptor, so this cannot + // happen unless something in this process is opening descriptors + // concurrently. Do not shuffle its descriptor around. + close(nullfd); + return; + } + } +} + +/* + * Note [Standard file descriptors must be open] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A process may be started with any of file descriptors 0, 1 and 2 closed -- + * from a shell, `prog >&-` does exactly that. Nothing then reserves those + * numbers, and open(), pipe() and socket() hand out the lowest free + * descriptor, so the next descriptor the runtime creates for itself takes one + * of them: the ticker's pipe, or a capability's IO manager control pipe. + * + * Nothing warns anybody. 'GHC.Internal.IO.StdHandles.stdout' is a CAF, so it + * is built the first time the program writes to stdout, which is long after + * that has happened, and it builds a 'Handle' over descriptor 1 -- which now + * belongs to the runtime. The program then writes its output into the + * runtime's own plumbing, and at exit closes it. + * + * What this looks like from the outside is a hang, because the descriptor the + * Handle has taken over is the read end of a pipe. It is a perfectly good + * descriptor, so nothing reports an error: poll() for POLLOUT on it simply + * never says yes, epoll_ctl() accepts a registration for it, and the thread + * waiting to write blocks for ever. See #24450, where this is `prog >&-` + * hanging after main has finished. + * + * Closing those descriptors is legal, so the runtime cannot refuse them; and + * moving only the descriptors the runtime opens would not help, since the + * first file the program itself opens would land on the free number instead. + * The fix is to leave no free number: open /dev/null onto whichever of 0, 1 + * and 2 are closed, before the runtime creates any descriptor of its own. + * Other runtimes do the same, and for the same reason. + * + * A program run this way therefore finds stdout connected to /dev/null rather + * than failing with EBADF on the first write. That is the price of the fix, + * and it is the behaviour such a program would get from most other language + * runtimes. + * + * Each substitute is opened for the access the descriptor would normally have: + * read-only for 0, write-only for 1 and 2. Opening all three for both would + * make the substitute something a real stdin or stdout is not, and writing to + * 'stdin' or reading from 'stdout' would then quietly succeed instead of + * failing with EBADF. + */ +#endif + void hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) { @@ -252,6 +336,12 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) stg_exit(1); } +#if !defined(mingw32_HOST_OS) + /* Before anything here opens a file descriptor of its own. + See Note [Standard file descriptors must be open]. */ + sanitiseStandardFds(); +#endif + #if defined(wasm32_HOST_ARCH) char *pwd = getenv("PWD"); if (pwd != NULL) { ===================================== testsuite/tests/rts/T24450.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- A process may be started with stdout closed -- `prog >&-` from a shell does +-- exactly that. Nothing then reserves descriptor 1, so the next descriptor +-- the runtime opens for itself takes it, and the 'Handle' for stdout, built +-- later when the program first writes, takes over a descriptor belonging to +-- the runtime. The write then goes into the runtime's own plumbing, and what +-- this looks like from the outside is a hang. See #24450 and +-- Note [Standard file descriptors must be open] in rts/RtsStartup.c. +-- +-- This test is run with its stdin and stdout closed, so what it has to say +-- goes to stderr. The four writes are the reproducer from the ticket and must +-- simply finish. The lines after them are what tell the two outcomes apart: +-- the descriptors the runtime opens for itself are pipes, so finding a pipe on +-- descriptor 0 or 1 means it was handed to the runtime. +module Main (main) where + +import Control.Exception (IOException, try) +import System.IO +import System.Posix.Files (getFdStatus, isCharacterDevice, isNamedPipe) +import System.Posix.Types (Fd (..)) + +main :: IO () +main = do + hPutChar stderr 'A' -- unbuffered + hPutChar stdout 'X' -- buffered; this is the one that used to hang + hPutChar stderr 'Z' -- unbuffered + hPutChar stderr '\n' -- unbuffered + mapM_ (\fd -> hPutStrLn stderr =<< describeFd fd) [0, 1] + +describeFd :: Fd -> IO String +describeFd fd = do + r <- try (getFdStatus fd) + return $ "fd " ++ show fd ++ ": " ++ case r of + Left (_ :: IOException) -> "closed" + Right st + -- What the fix arranges: /dev/null, opened onto the free number + -- before the runtime could take it. + | isCharacterDevice st -> "character device" + -- What #24450 is: the runtime's ticker or control pipe. + | isNamedPipe st -> "pipe" + | otherwise -> "something else" ===================================== testsuite/tests/rts/T24450.stderr ===================================== @@ -0,0 +1,3 @@ +AZ +fd 0: character device +fd 1: character device ===================================== testsuite/tests/rts/all.T ===================================== @@ -408,6 +408,18 @@ test('T10590', [ ignore_stderr , req_process ], compile_and_run, ['']) +# Run with stdin and stdout closed -- that is what leaves those descriptors +# free for the runtime to take, which is the whole of #24450. What the test +# has to say therefore goes to stderr and is checked against T24450.stderr. +test('T24450', + [ when(opsys('mingw32'), skip) # POSIX only + , js_skip # JS backend has its own runtime + # The wrapper below would close the stdout of the wasm runtime rather + # than that of the program running under it, which tests nothing. + , when(arch('wasm32'), skip) + , cmd_wrapper(lambda c: c + ' <&- >&-') + ], compile_and_run, ['']) + # 20000 was easily enough to trigger the bug with 7.10 test('T10904', [ extra_run_opts('20000'), req_c ], compile_and_run, ['T10904lib.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03383bf1c43812511c0fb888d4660b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03383bf1c43812511c0fb888d4660b… 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/multi-threaded-debugger] 3 commits: Asynchronous RPC with external interpreter
by Rodrigo Mesquita (＠alt-romes) 06 Oct '26

06 Oct '26

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC Commits: 5f600346 by Rodrigo Mesquita at 2026-10-06T17:45:16+01:00 Asynchronous RPC with external interpreter - Kill InterpProcess.interpLock to Pipe.pipeLock - - - - - 1c15fcb9 by Rodrigo Mesquita at 2026-10-06T19:27:25+01:00 Async more work - - - - - 2540e67a by Rodrigo Mesquita at 2026-10-06T19:28:18+01:00 WIP: Asynchronous eval/resume - - - - - 9 changed files: - compiler/GHC/Runtime/Eval.hs - 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 - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs Changes: ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -188,12 +188,13 @@ execOptions = ExecOptions -- by default we just care about breakpoints hit in this eval thread } --- | Run a statement in the current interactive context. +-- | Run a statement in the current interactive context, as a new thread in the interpreter. +-- Returns an action which blocks waiting for the execution to finish and yield a result. execStmt :: GhcMonad m => String -- ^ a statement (bind or expression) -> ExecOptions - -> m ExecResult + -> m (m ExecResult) execStmt input exec_opts@ExecOptions{..} = do hsc_env <- getSession @@ -204,13 +205,15 @@ execStmt input exec_opts@ExecOptions{..} = do case mb_stmt of -- empty statement / comment - Nothing -> return (ExecComplete (Right []) 0) + Nothing -> pure (pure (ExecComplete (Right []) 0)) Just stmt -> execStmt' stmt input exec_opts -- | Like `execStmt`, but takes a parsed statement as argument. Useful when -- doing preprocessing on the AST before execution, e.g. in GHCi (see -- GHCi.UI.runStmt). -execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult +-- +-- Returns an action which blocks waiting for the execution to finish and yield a result. +execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m (m ExecResult) execStmt' stmt stmt_text ExecOptions{..} = do hsc_env <- getSession let interp = hscInterp hsc_env @@ -226,21 +229,22 @@ execStmt' stmt stmt_text ExecOptions{..} = do case r of Nothing -> -- empty statement / comment - return (ExecComplete (Right []) 0) + pure (pure (ExecComplete (Right []) 0)) Just (ids, hval, fix_env) -> do updateFixityEnv fix_env let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep) (enableIsolateThreadBreaks execIsolateMode) - status <- liftIO $ evalStmt interp eval_opts (execWrap hval) + rtid <- liftIO $ evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_gre_cache ic) size = ghciHistSize idflags' - - handleRunStatus execSingleStep eval_opts stmt_text bindings ids - status (emptyHistory size) + pure $ do + status <- liftIO (waitThreadResult interp rtid) + handleRunStatus execSingleStep eval_opts stmt_text bindings ids + status (emptyHistory size) runDecls :: GhcMonad m => String -> m [TyThing] runDecls = runDeclsWithLocation "<interactive>" 1 @@ -326,16 +330,16 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do return (ExecComplete (Left (fromSerializableException e)) alloc) -- Nothing case: we stopped when an exception was raised, not at a breakpoint. - EvalBreak apStack_ref Nothing resume_ctxt ccs -> do - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + EvalBreak apStack_ref Nothing resume_tid ccs -> do + resume_tid_fhv <- liftIO $ mkFinalizedHValue interp resume_tid + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let span = mkGeneralSrcSpan (fsLit "<unknown>") (hsc_env1, break_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing let resume = Resume { resumeStmt = expr - , resumeContext = resume_ctxt_fhv + , resumeContext = resume_tid_fhv , resumeBindings = bindings , resumeFinalIds = final_ids , resumeApStack = apStack_fhv @@ -356,7 +360,7 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do -- The interpreter yields on a breakpoint if: -- - the breakpoint was explicitly enabled (in @BreakArray@) -- - or one of the stepping options in @EvalOpts@ caused us to stop at one - EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do + EvalBreak apStack_ref (Just eval_break) resume_tid ccs -> do let ibi = evalBreakpointToId eval_break let hug = hsc_HUG hsc_env info_brks <- liftIO $ readIModBreaks hug ibi @@ -368,8 +372,8 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do breakArray <- getBreakArray interp ibi info_brks breakpointStatus interp breakArray (ibi_info_index ibi) - apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + resume_tid_fhv <- liftIO $ mkFinalizedHValue interp resume_tid -- This breakpoint is enabled or we mean to break here; -- we want to stop instead of just logging it. @@ -382,7 +386,7 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do let resume = Resume { resumeStmt = expr - , resumeContext = resume_ctxt_fhv + , resumeContext = resume_tid_fhv , resumeBindings = bindings , resumeFinalIds = final_ids , resumeApStack = apStack_fhv @@ -398,7 +402,9 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do return (ExecBreak break_ids (Just ibi) resume) else do -- resume with the same step type - status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv + status <- liftIO $ do + GHCi.resumeStmt interp eval_opts resume_tid_fhv + GHCi.waitThreadResult interp resume_tid_fhv history <- if not tracing then pure history0 else do history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 @@ -414,7 +420,9 @@ resumeExec :: GhcMonad m -> ThreadBreaksIsolationMode -> Maybe Int -> Resume - -> m ExecResult + -> m (m ExecResult) + -- ^ Returns an action which blocks waiting for the resumed thread + -- to break again or yield a result resumeExec step isolateMode mbCnt r = do hsc_env <- getSession let ic = hsc_IC hsc_env @@ -438,7 +446,7 @@ resumeExec step isolateMode mbCnt r = do case r of Resume { resumeStmt = expr - , resumeContext = fhv + , resumeContext = rtid , resumeBindings = bindings , resumeFinalIds = final_ids , resumeApStack = apStack @@ -454,17 +462,19 @@ resumeExec step isolateMode mbCnt r = do let eval_opts = initEvalOpts dflags (enableGhcStepMode step) (enableIsolateThreadBreaks isolateMode) - status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv - let prevHistoryLst = fromListBL 50 hist - hug = hsc_HUG hsc_env - hist' = case mb_brkpt of - Nothing -> pure prevHistoryLst - Just bi - | breakHere False step span -> do - hist1 <- liftIO (mkHistory hug apStack bi) - return $ hist1 `consBL` fromListBL 50 hist - | otherwise -> pure prevHistoryLst - handleRunStatus step eval_opts expr bindings final_ids status =<< hist' + liftIO $ GHCi.resumeStmt interp eval_opts rtid + pure $ do + status <- liftIO $ GHCi.waitThreadResult interp rtid + let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env + hist' = case mb_brkpt of + Nothing -> pure prevHistoryLst + Just bi + | breakHere False step span -> do + hist1 <- liftIO (mkHistory hug apStack bi) + return $ hist1 `consBL` fromListBL 50 hist + | otherwise -> pure prevHistoryLst + handleRunStatus step eval_opts expr bindings final_ids status =<< hist' setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 setupBreakpoint interp ibi cnt = do @@ -1275,7 +1285,9 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do updateFixityEnv fix_env let eval_opts = initEvalOpts dflags EvalStepNone True - status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) + status <- liftIO $ do + rtid <- evalStmt interp eval_opts (EvalThis hvals_io) + waitThreadResult interp rtid case status of EvalComplete _ (EvalSuccess [hval]) -> return hval EvalComplete _ (EvalException e) -> ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Runtime.Interpreter , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) , resumeStmt , abandonStmt + , waitThreadResult , evalIO , evalString , evalStringToIOString @@ -286,11 +287,11 @@ evalStmt :: Interp -> EvalOpts -> EvalExpr ForeignHValue - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) + -> IO (ForeignRef ThreadId) evalStmt interp opts foreign_expr = do - status <- withExpr foreign_expr $ \expr -> + r <- withExpr foreign_expr $ \expr -> interpCmd interp (EvalStmt opts expr) - handleEvalStatus interp status + mkFinalizedHValue interp r where withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a withExpr (EvalThis fhv) cont = @@ -304,17 +305,25 @@ resumeStmt :: Interp -> EvalOpts -> ForeignRef ThreadId - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) + -> IO () resumeStmt interp opts resume_tid = do - status <- withForeignRef resume_tid $ \rhv -> + withForeignRef resume_tid $ \rhv -> interpCmd interp (ResumeStmt opts rhv) - handleEvalStatus interp status abandonStmt :: Interp -> ForeignRef ThreadId -> IO () abandonStmt interp resume_tid = withForeignRef resume_tid $ \rhv -> interpCmd interp (AbandonStmt rhv) +waitThreadResult + :: Interp + -> ForeignRef ThreadId + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +waitThreadResult interp tid = do + status <- withForeignRef tid $ \rhv -> do + interpCmd interp (WaitThreadResult rhv) + handleEvalStatus interp status + handleEvalStatus :: Interp -> EvalStatus [HValueRef] @@ -417,8 +426,9 @@ whereFrom interp ref = seqHValue :: Interp -> UnitEnv -> Logger -> ForeignHValue -> IO (EvalResult ()) seqHValue interp unit_env logger ref = withForeignRef ref $ \hval -> do - status <- interpCmd interp (Seq hval) - handleSeqHValueStatus interp unit_env logger status + rtid <- interpCmd interp (Seq hval) + status <- interpCmd interp (WaitThreadResult rtid) + handleSeqHValueStatus interp unit_env logger (clearEvalStatus status) evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId evalBreakpointToId eval_break = @@ -460,9 +470,10 @@ handleSeqHValueStatus interp unit_env logger eval_status = Just modbreaks -> put =<< getBreakLoc (readIModModBreaks hug) ibi modbreaks -- resume the seq (:force) processing in the iserv process - withForeignRef resume_ctxt_fhv $ \hval -> do - status <- interpCmd interp (ResumeSeq hval) - handleSeqHValueStatus interp unit_env logger status + withForeignRef resume_ctxt_fhv $ \rtid -> do + interpCmd interp (ResumeSeq rtid) + status <- interpCmd interp (WaitThreadResult rtid) + handleSeqHValueStatus interp unit_env logger (clearEvalStatus status) (EvalComplete _ r) -> return r @@ -626,11 +637,9 @@ spawnIServ conf = do [] (iservConfOpts conf) interpPipe <- mkPipeFromHandles rh wh - lock <- newMVar () let process = InterpProcess { interpHandle = ph , interpPipe - , interpLock = lock } pending_frees <- newMVar [] @@ -771,3 +780,9 @@ readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaks fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a + +clearEvalStatus :: EvalStatus a -> EvalStatus () +clearEvalStatus = \case + EvalComplete w (EvalException se) -> EvalComplete w (EvalException se) + EvalComplete w (EvalSuccess _) -> EvalComplete w (EvalSuccess ()) + EvalBreak ap mb rt rccs -> EvalBreak ap mb rt rccs ===================================== 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,7 @@ 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 ) where @@ -27,79 +18,13 @@ 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 -- ----------------------------------------------------------------------------- -- 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. 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 --- --- 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 () - +sendMessage i m = callInterpProcess (instProcess i) m -- | Send a 'Message' and receive the response from the interpreter process callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a @@ -107,18 +32,6 @@ 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 - handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a handleInterpProcessFailure i e = do let hdl = interpHandle i ===================================== 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 = () ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -12,7 +12,7 @@ module GHCi.Message ( Message(..), Msg(..) , ConInfoTable(..) - , THMessage(..), THMsg(..) + , THMessage(..) -- , THMsg(..) , QResult(..) , EvalStatus_(..,EvalBreak), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , EvalBreak(..), EvalBreakpoint (..) @@ -20,7 +20,7 @@ module GHCi.Message , toSerializableException, fromSerializableException , THResult(..), THResultType(..) , QState(..) - , getMessage, putMessage, getTHMessage, putTHMessage + , getMessage, putMessage, {- getTHMessage, -} putTHMessage , Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe , BreakModule , BreakUnitId @@ -62,6 +62,8 @@ import Data.Dynamic import Data.Typeable (TypeRep) import Data.IORef import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import Foreign import GHC.Generics import GHC.Stack.CCS @@ -70,6 +72,7 @@ import qualified GHC.Boot.TH.Monad as TH import System.Exit import System.IO import System.IO.Error +import Control.Monad -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -132,13 +135,13 @@ data Message a where EvalStmt :: EvalOpts -> EvalExpr HValueRef {- IO [a] -} - -> Message (EvalStatus [HValueRef]) {- [a] -} + -> Message (RemoteRef ThreadId) {- [a] -} -- | Resume evaluation of a statement after a breakpoint ResumeStmt :: EvalOpts -> RemoteRef ThreadId - -> Message (EvalStatus [HValueRef]) + -> Message () -- | Abandon evaluation of a statement after a breakpoint AbandonStmt @@ -240,12 +243,23 @@ data Message a where -- | Evaluate something. This is used to support :force in GHCi. Seq :: HValueRef - -> Message (EvalStatus ()) + -> Message (RemoteRef ThreadId) -- | Resume forcing a free variable in a breakpoint (#2950) ResumeSeq :: RemoteRef ThreadId - -> Message (EvalStatus ()) + -> Message () + + WaitThreadResult + :: RemoteRef ThreadId + -> Message (EvalStatus [HValueRef]) + + WaitAnyThreadBreak + :: Message EvalBreak + + WaitThreadResultOrAnyThreadBreak + :: RemoteRef ThreadId + -> Message (EvalStatus [HValueRef]) -- | User-defined request encoded as a tag/payload pair. This is left -- uninterpreted by GHC and is meant for GHC API applications to be able to supply @@ -323,40 +337,40 @@ data THMessage a where deriving instance Show (THMessage a) -data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a) - -getTHMessage :: Get THMsg -getTHMessage = do - b <- getWord8 - case b of - 0 -> THMsg <$> NewName <$> get - 1 -> THMsg <$> (Report <$> get <*> get) - 2 -> THMsg <$> (LookupName <$> get <*> get) - 3 -> THMsg <$> Reify <$> get - 4 -> THMsg <$> ReifyFixity <$> get - 5 -> THMsg <$> (ReifyInstances <$> get <*> get) - 6 -> THMsg <$> ReifyRoles <$> get - 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get) - 8 -> THMsg <$> ReifyModule <$> get - 9 -> THMsg <$> ReifyConStrictness <$> get - 10 -> THMsg <$> AddDependentFile <$> get - 11 -> THMsg <$> AddTempFile <$> get - 12 -> THMsg <$> AddTopDecls <$> get - 13 -> THMsg <$> (IsExtEnabled <$> get) - 14 -> THMsg <$> return ExtsEnabled - 15 -> THMsg <$> return StartRecover - 16 -> THMsg <$> EndRecover <$> get - 17 -> THMsg <$> return FailIfErrs - 18 -> return (THMsg RunTHDone) - 19 -> THMsg <$> AddModFinalizer <$> get - 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) - 21 -> THMsg <$> AddCorePlugin <$> get - 22 -> THMsg <$> ReifyType <$> get - 23 -> THMsg <$> (PutDoc <$> get <*> get) - 24 -> THMsg <$> GetDoc <$> get - 25 -> THMsg <$> return GetPackageRoot - 26 -> THMsg <$> AddDependentDirectory <$> get - n -> error ("getTHMessage: unknown message " ++ show n) +-- data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a) +-- +-- getTHMessage :: Get THMsg +-- getTHMessage = do +-- b <- getWord8 +-- case b of +-- 0 -> THMsg <$> NewName <$> get +-- 1 -> THMsg <$> (Report <$> get <*> get) +-- 2 -> THMsg <$> (LookupName <$> get <*> get) +-- 3 -> THMsg <$> Reify <$> get +-- 4 -> THMsg <$> ReifyFixity <$> get +-- 5 -> THMsg <$> (ReifyInstances <$> get <*> get) +-- 6 -> THMsg <$> ReifyRoles <$> get +-- 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get) +-- 8 -> THMsg <$> ReifyModule <$> get +-- 9 -> THMsg <$> ReifyConStrictness <$> get +-- 10 -> THMsg <$> AddDependentFile <$> get +-- 11 -> THMsg <$> AddTempFile <$> get +-- 12 -> THMsg <$> AddTopDecls <$> get +-- 13 -> THMsg <$> (IsExtEnabled <$> get) +-- 14 -> THMsg <$> return ExtsEnabled +-- 15 -> THMsg <$> return StartRecover +-- 16 -> THMsg <$> EndRecover <$> get +-- 17 -> THMsg <$> return FailIfErrs +-- 18 -> return (THMsg RunTHDone) +-- 19 -> THMsg <$> AddModFinalizer <$> get +-- 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) +-- 21 -> THMsg <$> AddCorePlugin <$> get +-- 22 -> THMsg <$> ReifyType <$> get +-- 23 -> THMsg <$> (PutDoc <$> get <*> get) +-- 24 -> THMsg <$> GetDoc <$> get +-- 25 -> THMsg <$> return GetPackageRoot +-- 26 -> THMsg <$> AddDependentDirectory <$> get +-- n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put putTHMessage m = case m of @@ -719,11 +733,27 @@ serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos) -- ----------------------------------------------------------------------------- -- Reading/writing messages +type CorrelationId = Int +data Request = Request !CorrelationId Msg +data Reply = Reply !CorrelationId LB.ByteString + +instance Binary Request where + put (Request i (Msg m)) = put i >> putMessage m + get = Request <$> get <*> getMessage + +instance Binary Reply where + put (Reply i bs) = put i >> put bs + get = Reply <$> get <*> get + -- | An opaque pipe for bidirectional binary data transmission. data Pipe = Pipe - { getSome :: !(IO ByteString) - , putAll :: !(B.Builder -> IO ()) - , pipeLeftovers :: !(IORef (Maybe ByteString)) + { getSome :: !(IO ByteString) + , putAll :: !(B.Builder -> IO ()) + , pipeLeftovers :: !(IORef (Maybe ByteString)) + , pipeLock :: !(MVar ()) -- ^ Lock to prevent concurrent access to the stream + , pipePending :: !(IORef (IntMap (MVar LB.ByteString))) + , pipeDrainThread :: !(MVar ThreadId) + , pipeNextReq :: !(IORef Int) } -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. @@ -733,30 +763,59 @@ mkPipeFromHandles pipeRead pipeWrite = do putAll b = do B.hPutBuilder pipeWrite b hFlush pipeWrite - pipeLeftovers <- newIORef Nothing - pure $ Pipe { getSome, putAll, pipeLeftovers } + mkPipeFromContinuations getSome putAll -- | 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 } + pipeLeftovers <- newIORef Nothing + pipeLock <- newMVar () + pipePending <- newIORef IntMap.empty + pipeDrainThread <- newEmptyMVar + pipeNextReq <- newIORef 0 + let p = Pipe { .. } + + -- Fork thread to drain read end. + drainTid <- forkIO (drainPipe p) + putMVar pipeDrainThread drainTid + -- todo: proper thread clean up and no leaks -remoteCall :: Binary a => Pipe -> Message a -> IO a + pure p + +remoteCall :: (Show a, 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 + -- Mark pending + uq <- freshReqId pipe + wv <- newEmptyMVar + atomicModifyIORef' (pipePending pipe) $ + \m -> (IntMap.insert uq wv m, ()) + + -- Write request + writePipe pipe (put (Request uq (Msg msg))) + + -- Block waiting for reply + runGet get <$> takeMVar wv remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a remoteTHCall pipe msg = do writePipe pipe (putTHMessage msg) readPipe pipe get +drainPipe :: Pipe -> IO () +drainPipe p = forever $ do + Reply uq bs <- readPipe p get + wv <- atomicModifyIORef' (pipePending p) $ \m -> do + case IntMap.lookup uq m of + Nothing -> error "drainPipe: Received reply to no pending request" + Just wv -> (IntMap.delete uq m, wv) + putMVar wv bs -- signal matching request + +writePipe :: Pipe -> Put -> IO () +writePipe p@Pipe{..} put = withLock p $ putAll $ execPut put + readPipe :: Pipe -> Get a -> IO a -readPipe Pipe{..} get = do +readPipe p@Pipe{..} get = withLock p $ do leftovers <- readIORef pipeLeftovers m <- getBin getSome get leftovers case m of @@ -786,3 +845,9 @@ getBin getsome get leftover = go leftover (runGetIncremental get) 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 + +freshReqId :: Pipe -> IO Int +freshReqId Pipe{pipeNextReq} = atomicModifyIORef' pipeNextReq $ \i -> (i+1, i) ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -128,6 +128,15 @@ run m = case m of Seq ref -> doSeq ref ResumeSeq ref -> resumeSeq ref + WaitThreadResult tid -> localRef tid >>= atomically . readThreadEvalStatus + WaitAnyThreadBreak -> atomically $ readAnyThreadEvalBreak + WaitThreadResultOrAnyThreadBreak t -> do + tid <- localRef t + atomically $ + readThreadEvalStatus tid + `orElse` + (EvalPaused <$> readAnyThreadEvalBreak) + Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m @@ -206,7 +215,7 @@ tryEval io = do -------------------------------------------------------------------------------- -evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef]) +evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (RemoteRef ThreadId) evalStmt opts expr = do io <- mkIO expr sandboxIO opts $ do @@ -248,16 +257,16 @@ evalStringToString r str = do -- The UI process has more and therefore also can show more -- information about the breakpoint than the current iserv -- process. -doSeq :: RemoteRef a -> IO (EvalStatus ()) -doSeq ref = clearEvalStatus <$> do +doSeq :: RemoteRef a -> IO (RemoteRef ThreadId) +doSeq ref = do sandboxIO evalOptsSeq $ do _ <- (void $ evaluate =<< localRef ref) return [] -- | Process a ResumeSeq message. Continue the :force processing #2950 -- after a breakpoint. -resumeSeq :: RemoteRef ThreadId -> IO (EvalStatus ()) -resumeSeq hvref = clearEvalStatus <$> resumeStmt evalOptsSeq hvref +resumeSeq :: RemoteRef ThreadId -> IO () +resumeSeq hvref = resumeStmt evalOptsSeq hvref evalOptsSeq :: EvalOpts evalOptsSeq = EvalOpts @@ -296,15 +305,16 @@ abandonStmt hvref = do -------------------------------------------------------------------------------- -resumeStmt :: EvalOpts -> RemoteRef ThreadId -> IO (EvalStatus [HValueRef]) +resumeStmt :: EvalOpts -> RemoteRef ThreadId -> IO () resumeStmt opts rtid = do resumeThreadId <- localRef rtid ResumeContext{..} <- getThreadResumeContext resumeThreadId - withBreakAction opts resumeThreadId $ \waitForResult -> - mask_ $ do - putMVar resumeBreakMVar () -- this awakens the stopped thread... - redirectInterrupts resumeThreadId $ - waitForResult + setBreakAction opts resumeThreadId -- See Note [TODO: all break options must be set every time] + -- withBreakAction opts resumeThreadId $ \waitForResult -> + -- mask_ $ do + putMVar resumeBreakMVar () -- this awakens the stopped thread... + -- redirectInterrupts resumeThreadId $ + -- waitForResult -- When running a computation, we redirect ^C exceptions to the running -- thread. ToDo: we might want a way to continue even if the target @@ -316,7 +326,7 @@ resumeStmt opts rtid = do -- only while we execute the user's code. We can't afford to lose the final -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) -sandboxIO :: EvalOpts -> IO [HValueRef] -> IO (EvalStatus [HValueRef]) +sandboxIO :: EvalOpts -> IO [HValueRef] -> IO (RemoteRef ThreadId) sandboxIO opts io | useSandboxThread opts = do @@ -336,17 +346,31 @@ sandboxIO opts io tid <- forkIO $ do takeMVar wait -- don't run anything in this thread before - -- `withBreakAction` has a chance to set up. + -- `setBreakAction` has a chance to set up. tid <- myThreadId labelThread tid "GHCi sandbox" + + -- WHEN THE THREAD IS FINISHED, write the value itself. + -- + -- we only write the TID status map in two places: + -- + -- When the "main" thread finishes (here) + -- When any thread hits a breakpoint (global break action) unsafeUnmask runIt >>= writeThreadEvalStatus tid + -- TODO: This unsafe-unmask is very dubious. Consult with Andrea. I + -- don't think we should be uninterruptable masking interp commands + -- somewhere else. This should just be runIt? - -- We are running in uninterruptibleMask - withBreakAction opts tid $ \waitForResult -> do - putMVar wait () - redirectInterrupts tid $ unsafeUnmask $ - waitForResult + -- We are running in uninterruptibleMask -- TODO WHY?? + setBreakAction opts tid + putMVar wait () + + mkRemoteRef tid + -- withBreakAction opts tid $ \waitForResult -> do + -- putMVar wait () + -- redirectInterrupts tid $ unsafeUnmask $ + -- waitForResult | otherwise = do @@ -360,7 +384,17 @@ sandboxIO opts io -- tracing, etc.) need the expression to be running in a -- separate thread, so debugging is only enabled when -- using the sandbox. - runIt + tid <- forkIO (pure ()) + runIt >>= writeThreadEvalStatus tid + mkRemoteRef tid + -- We `runIt` on the main thread, but fork a new thread to store to the + -- result with `writeThreadEvalStatus` to fit the asynchronous API. We + -- can't use myThreadId because if the user happens to runIt twice + -- before awaiting, the second result will clobber the first. + + -- TODO We have to be careful evacuating this map bc there may be + -- uncollected results from finished threads. So the thread map can't + -- be weak refs ? Or maybe because of the RemoteRef it's fine. Ah, prob. where runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io @@ -415,12 +449,16 @@ sandboxIO opts io -- whenever "main" or one of the threads spawned by "main" hit a breakpoint, -- rather than just "main" being observed. This should be used for the main -- debuggee execution of a debugger. -withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a -withBreakAction opts tid@(ThreadId tid#) act = do +-- withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a +-- withBreakAction opts tid@(ThreadId tid#) act = do + +setBreakAction :: EvalOpts -> ThreadId -> IO () +setBreakAction opts tid@(ThreadId tid#) = do ctx <- getThreadResumeContext tid - bracket (setBreakAction ctx) (resetBreakAction ctx) (\_ -> act (waitForResult ctx)) + setBreakAction' ctx + -- bracket _ (resetBreakAction ctx) (\_ -> act (waitForResult ctx)) where - setBreakAction ctx = do + setBreakAction' ctx = do -- TODO: TERRIBLY NOT MULTI-THREAD FRIENDLY. Each thread needs its own RTS flag exceptionFlag, like we have for step-in or step-out. runIf breakOnException $ \_ -> poke exceptionFlag 1 -- Breaking on exceptions is not enabled by default, since it @@ -433,7 +471,7 @@ withBreakAction opts tid@(ThreadId tid#) act = do runIfCtx ctx isolateThreadBreaks setIsolatedCtx resetBreakAction ctx () = do - poke exceptionFlag 0 + poke exceptionFlag 0 -- just wrong, expection flag should be per-thread rts_disableStopAfterReturn tid# rts_disableStopNextBreakpoint tid# runIfCtx ctx isolateThreadBreaks unsetIsolatedCtx @@ -485,9 +523,3 @@ redirectInterrupts target wait = do Nothing -> wait Just target -> do throwTo target (e :: SomeException); wait -clearEvalStatus :: EvalStatus a -> EvalStatus () -clearEvalStatus = \case - EvalComplete w (EvalException se) -> EvalComplete w (EvalException se) - EvalComplete w (EvalSuccess _) -> EvalComplete w (EvalSuccess ()) - EvalBreak ap mb rt rccs -> EvalBreak ap mb rt rccs - ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -70,6 +70,14 @@ servWithCustom verbose hook pipe restore customHandler = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + -- The expressions which block waiting for a result musn't block the + -- server thread, so send them off and notify over the wire when done. + -- + -- The other end (see 'remoteCall') will be processing notifications, and + -- it will use the returned pointer as the index for the matching notification. + WaitThreadResult {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef + WaitAnyThreadBreak {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef + WaitThreadResultOrAnyThreadBreak {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7150ad38a9ef92ff9a00e345b5b3f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7150ad38a9ef92ff9a00e345b5b3f… 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/az/epa-tidy-locatedxxx-27] 4 commits: hadrian: Persist the used flavour name in the build root (#20650)
by Alan Zimmerman (＠alanz) 06 Oct '26

06 Oct '26

Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-27 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - ec341aeb by Alan Zimmerman at 2026-10-06T18:26:37+01: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. - - - - - 13 changed files: - + changelog.d/hadrian-persist-flavour - changelog.d/unit-index - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Parser.y - distrib/configure.ac.in - hadrian/doc/flavours.md - hadrian/src/Rules.hs - hadrian/src/Settings.hs - m4/subst_tooldir.m4 - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T - testsuite/tests/parser/should_compile/DumpSemis.stderr Changes: ===================================== changelog.d/hadrian-persist-flavour ===================================== @@ -0,0 +1,7 @@ +section: packaging +synopsis: Hadrian now persists the flavour name in the build root. When + rebuilding, the previously used flavour is automatically restored, removing + the need to re-specify it on every invocation and avoiding accidental build + root invalidation. +issues: #20650 +mrs: !7017 ===================================== changelog.d/unit-index ===================================== @@ -1,7 +1,7 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 #27748 #27834 -mrs: !16115 !16598 !16743 +issues: #27500 #26423 #27748 #27834 #27835 +mrs: !16115 !16598 !16743 !16748 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do } let uic = hscUIC hsc_env liftIO $ cacheExternalUnitDatabase uic newdb - -- added at the end because ordering matters + -- Ordering matters here! We prepend the new unit database, because 'packageDBFlags' + -- works like a stack, where what's on top takes precedence over what's below (same as right-to-left when given at the CLI). + -- The new db needs highest precedence to overwrite any other in-memory units that potentially occur in the dbs below it. pure dflags - { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags } -- | Register a new virtual unit database containing a single unit ===================================== 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) ===================================== distrib/configure.ac.in ===================================== @@ -103,7 +103,7 @@ AC_ARG_ENABLE(distro-toolchain, AC_SUBST([EnableDistroToolchain]) if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then - FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/]) + FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$topdir/../mingw/]) fi ===================================== hadrian/doc/flavours.md ===================================== @@ -3,7 +3,14 @@ Hadrian supports a few predefined _build flavours_, i.e. collections of build settings that fully define a GHC build (see `src/Flavour.hs`). Users can add their own build flavours if need be, as described -[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#build-flavour). +[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#build-flavour) or modify existing flavours using the flavour transformers notion seem below. + +The flavour to be used for a build root can be specified on the command-line +via the `--flavour` flag. Moreover, this flavour name is saved in the build +root; future invocations of Hadrian without a `--flavour` flag will default to +the last-used flavour. + +See `Note [Persisting the flavour]` in `hadrian/src/Settings.hs` ## Arguments ===================================== hadrian/src/Rules.hs ===================================== @@ -129,6 +129,7 @@ packageRules = do buildRules :: Rules () buildRules = do + Settings.flavourFileRules Rules.BinaryDist.bindistRules Rules.Generate.copyRules Rules.Generate.generateRules ===================================== hadrian/src/Settings.hs ===================================== @@ -1,10 +1,14 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + module Settings ( getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath, isLibrary, stagePackages, getBignumBackend, completeSetting, queryBuildTarget, queryHostTarget, queryBuild, queryHost, - queryArch, queryOS, queryVendor + queryArch, queryOS, queryVendor, + flavourFileRules ) where import CommandLine @@ -58,6 +62,56 @@ hadrianFlavours = , ghcInGhciFlavour, validateFlavour, slowValidateFlavour ] +{- +Note [Persisting the flavour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Passing the flavour on the command-line means the user must consistently pass +the same --flavour flag to all Hadrian invocations on a particular build root. +Forgetting even once can result in a full rebuild of the tree. + +To avoid this we persist the flavour name in the build root itself +(specifically, in `<build root>/flavour`). We refer to this file when looking +up the active flavour, defaulting to it if the user does not specify a flavour +name explicitly. +-} + +-- | Oracle query type for the active flavour name. +-- See Note [Persisting the flavour]. +newtype FlavourName = FlavourName () + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult FlavourName = String + +flavourFileRules :: Rules () +flavourFileRules = do + root <- buildRootRules + + -- Cache the flavour name lookup for the whole Shake run. + -- alwaysRerun ensures the oracle re-executes on every new invocation so + -- that a changed --flavour flag is never ignored due to a stale cross-run + -- cache entry (CLI args are not tracked as Shake dependencies). + -- See Note [Persisting the flavour]. + void $ addOracleCache $ \(FlavourName _) -> do + alwaysRerun + let flavourFile = root -/- "flavour" + cmdFlavour >>= \case + Just nm -> do + putBuild $ "Flavour: " ++ nm + liftIO $ writeFile flavourFile nm + return nm + Nothing -> do + exists <- doesFileExist flavourFile + if exists + then do nm <- liftIO $ readFile flavourFile + putBuild $ "Flavour: " ++ nm ++ " (cached from last build, override by passing --flavour=... explicitly)" + return nm + else return userDefaultFlavour + +-- | Lookup the requested flavour name, referring to the persistent flavour +-- file saved from the previous Hadrian execution if not specified. +-- The result is cached for the whole Shake run via the 'FlavourName' oracle. +getFlavourName :: Action String +getFlavourName = askOracle (FlavourName ()) + -- | This action looks up a flavour with the name given on the -- command line with @--flavour@, defaulting to 'userDefaultFlavour' -- when no explicit @--flavour@ is passed. It then applies any @@ -66,7 +120,7 @@ hadrianFlavours = -- syntax. See Note [Hadrian settings] at the bottom of this file. flavour :: Action Flavour flavour = do - flavourName <- fromMaybe userDefaultFlavour <$> cmdFlavour + flavourName <- getFlavourName when ("quickest" `isPrefixOf` flavourName) $ fail $ "The `quickest` flavour has been deprecated. Use `quick` instead.\n" ++ "Skip building dynamic libraries with `quick+no_dynamic_libs`\n" ===================================== m4/subst_tooldir.m4 ===================================== @@ -41,5 +41,5 @@ dnl ghc-toolchain. # See Note [How we configure the bundled windows toolchain] AC_DEFUN([SUBST_TOOLDIR], [ - sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' + sed -i.bkp 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' $1 ]) ===================================== testsuite/tests/backpack/should_compile/T27835.bkp ===================================== @@ -0,0 +1,11 @@ +unit p where + module P where + p :: Int + p = 42 + +unit q where + dependency p + module Q where + import P + q :: Int + q = p + 1 ===================================== testsuite/tests/backpack/should_compile/T27835.stderr ===================================== @@ -0,0 +1,7 @@ +[1 of 2] Processing p + Instantiating p + [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p + [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o ) ===================================== testsuite/tests/backpack/should_compile/all.T ===================================== @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, ['']) test('T13323', normal, backpack_compile, ['']) test('T20396', normal, backpack_compile, ['']) test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace']) +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db']) ===================================== 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/-/compare/fbf72978dae224dce5a366cf0f1f74… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbf72978dae224dce5a366cf0f1f74… 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/torsten.schmits/worker-gbc] 5 commits: Expose the constructor of ReachabilityIndex
by Torsten Schmits (＠torsten.schmits) 06 Oct '26

06 Oct '26

Torsten Schmits pushed to branch wip/torsten.schmits/worker-gbc at Glasgow Haskell Compiler / GHC Commits: 8a617663 by Ian-Woo Kim at 2026-10-06T19:38:06+02:00 Expose the constructor of ReachabilityIndex - - - - - 4dd8ceab by Andrea Vezzosi at 2026-10-06T19:38:06+02:00 Backport of bytecode objects and bytecode libraries Cherry-picked these commits and their dependencies: - 8f9ae3397d Load bytecode libraries to satisfy package dependencies - e36a5fcbea Add support for building bytecode libraries - 6bd8155c99 Add support for generating bytecode objects ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiComponentModulesRecomp MultiLayerModulesRecomp MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot TcPlugin_RewritePerf ------------------------- Full list of cherry-picked commits: rts/Interpreter: Factor out ctoi tuple info tables into data (cherry picked from commit d2b89603425b6d08df199deb7b84cfdbd711869a) compiler: only use `Name` instead of `Id` in `SptEntry` (cherry picked from commit 39b2e3823da3ab168aa2b7365f0f27e01b1ecd0e) Generalise thNameToGhcName by adding HasHscEnv (cherry picked from commit eb2ab1e2cadde93c330330ca7fdc64b31cd61473) Refactor ForAllCo (cherry picked from commit 94b62aa7e7b40b53442161a0c4f380955fda2f14) ghci: add :shell command (cherry picked from commit 06d2562362768051e4901878248cbad103e66e92) testsuite: remove legacy :shell trick (cherry picked from commit 186054f7e7a190ee175a6e93c6cfb63b8a67baca) docs: document :shell in ghci (cherry picked from commit 0a3a4aa30894820731e646e2788e9819b10a7d07) compiler/ghci: replace the LoadDLL message with LoadDLLs (cherry picked from commit a4d664c78642438f0f178ffa243e2ffdbdf20397) driver: separate downsweep/upsweep phase in loadPackages' (cherry picked from commit c7fc4baeddcfad500126b2e91ce94d2b9391560d) driver: emit single LoadDLLs message to load multiple DLLs (cherry picked from commit ab180104b61a930e8a1e906f013c151669ce6fff) driver: Load bytecode static pointer entries during linking (cherry picked from commit e9445c013fbccf9318739ca3d095a3e0a2e1be8a) loader: Unify loadDecls and loadModuleLinkables functions (cherry picked from commit da9633a9009a08132b974b0407c4057cae3577f7) testsuite: Use ghci_ways to set ways in PackedDataCon/UnboxedTuples/UnliftedDataTypeInterp tests (cherry picked from commit 1275d3607299734228adbbc47bfb69bf8800279f) Rename interpreterBackend to bytecodeBackend (cherry picked from commit c06b534bbd6dbb570b760f2e82b3e375d3956bcf) Improvements to 'mayLookIdentical' (cherry picked from commit 2b8baada761b13199b99268f243bebd009e6e1b5) Store SDoc context in SourceError (cherry picked from commit 129ce32d3a4f2601f5c2d1bbaeeb2fbaf8dc9ef9) Add support for generating bytecode objects (cherry picked from commit 6bd8155c991cfce7cca594bc63ba8f6ca6751667) rts: Eliminate uses of implicit constant arrays (cherry picked from commit 0c00c9c3b4e9b8515d4839f2c1d7d771781dc6f4) rts: use computed goto for instruction dispatch in the bytecode interpreter (cherry picked from commit 39567e85fa514c0c4dfeaf8faa586a47dd3e11ca) Remove the `CoreBindings` constructor from `LinkablePart` (cherry picked from commit b253013ebeea5273a1cc7bb0082ed952456af906) driver: Properly handle errors during LinkNode steps (cherry picked from commit 6c91582f915f80daff774db7738094bda6ab3b44) Build external interpreter program on demand (#24731) (cherry picked from commit 55eab80d337e47decacbe979c29a1b7b47d0a872) Use 'OsPath' in getModificationTimeIfExists (cherry picked from commit ef0dc33b2034fd91e11950751264e8b2e9f03fc4) Use OsPath in PkgDbRef and UnitDatabase, not FilePath (cherry picked from commit fa3bd0a67eea13701d1b50053636f9645e999308) Add support for building bytecode libraries (cherry picked from commit e36a5fcbeaa33abb17707173c9d1e81730f85008) Load bytecode libraries to satisfy package dependencies (cherry picked from commit 8f9ae3397dbcbb4b0bd7a574ffc6b1fbaa137b6c) - - - - - 8c5c29c9 by Andrea Vezzosi at 2026-10-06T19:38:19+02:00 Backport of bytecode objects relevant bugfixes. Cherry-pick of these commits and what they depend on - 28f07d702a Make HPC work with bytecode interpreter - d95a19366f Add constants for bytecode in-memory buffer size - 9b64ad3a45 determinism: Use a deterministic renaming when writing bytecode files ------------------------- Metric Decrease: interpreter_steplocal Metric Increase: MultiComponentModules MultiComponentModulesRecomp MultiLayerModulesRecomp MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot T13701 TcPlugin_RewritePerf -------------------------- All cherry-picked commits, oldest first: driver: Hide source paths at verbosity level 1 by default (cherry picked from commit aa9c5e2ca0d42f7361fc465d79f5beb056987a41) determinism: Use a deterministic renaming when writing bytecode files Fixes #26499 (cherry picked from commit 9b64ad3a458bf4e4165f125059e4bc3d518c5834) compiler: implement string interning logic for BCONPtrFS (cherry picked from commit d054b4676298ea2189cd48fcf175676b97f559e7) compiler: use `Binary` instance of `BCOByteArray` for bytecode objects (cherry picked from commit fdf828aef8c78ae23ad058ed4696910b6beba232) Support arbitrary size unboxed tuples in bytecode (cherry picked from commit a85bd503a480cfa31f5afa09eb38f56c85c237de) Add specialized frames for small tuples (cherry picked from commit e2209031734770a51f04883e5b538b562449cba1) Extract Binary instances to `GHC.ByteCode.Binary` (cherry picked from commit acffb1b1da1a59dbded9ec2dcb65e495aee31f40) Add `seqNonEmpty` for evaluating `NonEmpty a` (cherry picked from commit e2ea8e25c5128afa8191669c751942348ab3043b) Record `LinkableUsage` instead of `Linkable` in `LoaderState` (cherry picked from commit 048b00b7c231dec199a4441caac279f3bbcd75f4) bytecode: Add magic header/version to bytecode files (cherry picked from commit 5cbc2c823fb0710c37f6e9144382dd59e0353782) Add constants for bytecode in-memory buffer size (cherry picked from commit d95a19366f64e6d866c8df0b1ab917884cc015dc) testsuite: filter stderr for static001 on darwin (cherry picked from commit b822c30aa6c0bf008c06c5bd4ee86313c40f652d) ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages (cherry picked from commit 8dd6f453348e467686bd222551c89ecc466d36f0) ghci: use ShortByteString for MkCostCentres message (cherry picked from commit 371ef200bcb2664c4511daca75f72a52c1473950) Expose startupHpc as an rts symbol (cherry picked from commit f3485446d8c90aa39ee633606b488253ae23a255) Make HPC work with bytecode interpreter (cherry picked from commit 28f07d702a1b47230122df22e84b60fda49897c5) - - - - - f465f17b by Cheng Shao at 2026-10-06T19:42:31+02:00 driver: add -dep-json -opt-json flags to ghc -M docs: document -dep-json -opt-json flags Rework protocol merge opt-json into dep-json normalize source filenames include more canonical variant of the package id choose the main library when -package matches multiple units with the same version allow specifying library deps with -package pkg:lib Backported to GHC 9.14 Co-authored-by: Ian-Woo Kim <ianwookim(a)gmail.com> - - - - - 2708daaf by Torsten Schmits at 2026-10-06T19:42:31+02:00 Split `getLinkDeps` and abstract over the interface This allows API clients to customize bytecode loading to implement on-demand compilation of interface core bindings. - - - - - 402 changed files: - + changelog.d/bytecode-interpreter-hpc-support - compiler/GHC.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - + compiler/GHC/ByteCode/Recomp/Binary.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Reduction.hs - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Data/Graph/Directed/Reachability.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Data/SmallArray.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/Backend/Internal.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/ByteCode.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Config/Finder.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Hooks.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - + compiler/GHC/Driver/MakeFile/JSON.hs - compiler/GHC/Driver/Messager.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - + compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Linker/Windows.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Plugins.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Settings.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToJS/StaticPtr.hs - compiler/GHC/SysTools/Tasks.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Utils/Unify.hs-boot - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/SourceError.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Types/TyThing/Ppr.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Misc.hs - compiler/GHC/Utils/Outputable.hs - compiler/ghc.cabal.in - docs/users_guide/extending_ghc.rst - docs/users_guide/ghci.rst - docs/users_guide/phases.rst - docs/users_guide/separate_compilation.rst - docs/users_guide/using.rst - ghc/GHCi/Leak.hs - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/src/Settings/Builders/RunTest.hs - libraries/ghc-boot/GHC/Unit/Database.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Apply.cmm - rts/Continuation.c - rts/ContinuationOps.cmm - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/Printer.c - rts/RaiseAsync.c - rts/RtsSymbols.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/Bytecodes.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/posix/OSMem.c - testsuite/config/ghc - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - testsuite/mk/test.mk - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/bytecode/T24634/T24634a.stdout - testsuite/tests/bytecode/T24634/T24634b.stdout - + testsuite/tests/bytecode/TLinkable/BCOTemplate.hs - + testsuite/tests/bytecode/TLinkable/LinkableUsage01.stderr - + testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr - + testsuite/tests/bytecode/TLinkable/Makefile - + testsuite/tests/bytecode/TLinkable/all.T - + testsuite/tests/bytecode/TLinkable/genLinkables.sh - + testsuite/tests/bytecode/TLinkable/linkable-space.hs - + testsuite/tests/bytecode/TLinkable/linkable-space.stdout - + testsuite/tests/bytecode/tuplestress/ByteCode.hs - + testsuite/tests/bytecode/tuplestress/Common.hs-incl - + testsuite/tests/bytecode/tuplestress/Obj.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.stdout - + testsuite/tests/bytecode/tuplestress/all.T - + testsuite/tests/cabal/Bytecode.hs - + testsuite/tests/cabal/BytecodeForeign.c - + testsuite/tests/cabal/BytecodeForeign.hs - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/bytecode.pkg - + testsuite/tests/cabal/bytecode.script - + testsuite/tests/cabal/bytecode_foreign.pkg - + testsuite/tests/cabal/bytecode_foreign.script - testsuite/tests/cabal/ghcpkg03.stderr - testsuite/tests/cabal/ghcpkg03.stderr-mingw32 - testsuite/tests/cabal/ghcpkg05.stderr - testsuite/tests/cabal/ghcpkg05.stderr-mingw32 - + testsuite/tests/cabal/pkg_bytecode.stderr - + testsuite/tests/cabal/pkg_bytecode.stdout - + testsuite/tests/cabal/pkg_bytecode_foreign.stderr - + testsuite/tests/cabal/pkg_bytecode_foreign.stdout - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout - + testsuite/tests/cabal/pkg_bytecode_with_o.stderr - + testsuite/tests/cabal/pkg_bytecode_with_o.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/cpranal/should_compile/T18174.stderr - testsuite/tests/driver/T11429c.stderr - testsuite/tests/driver/T20030/test1/all.T - testsuite/tests/driver/T20030/test2/all.T - testsuite/tests/driver/T20030/test3/all.T - testsuite/tests/driver/T20030/test4/all.T - testsuite/tests/driver/T20030/test5/all.T - testsuite/tests/driver/T20030/test6/all.T - testsuite/tests/driver/T21682.stderr - + testsuite/tests/driver/T24384/A.hs - + testsuite/tests/driver/T24384/B.hs - + testsuite/tests/driver/T24384/C.hs - + testsuite/tests/driver/T24384/C.hs-boot - + testsuite/tests/driver/T24384/D.hs - + testsuite/tests/driver/T24384/E.hs - + testsuite/tests/driver/T24384/Makefile - + testsuite/tests/driver/T24384/T24384.stdout - + testsuite/tests/driver/T24384/all.T - + testsuite/tests/driver/T24384/preproc.sh - + testsuite/tests/driver/T24384/setup-dep.sh - + testsuite/tests/driver/T24731.hs - testsuite/tests/driver/T5313.hs - testsuite/tests/driver/T8526/T8526.script - testsuite/tests/driver/all.T - + testsuite/tests/driver/bytecode-object/A.hs - + testsuite/tests/driver/bytecode-object/BytecodeForeign.c - + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs - + testsuite/tests/driver/bytecode-object/BytecodeMain.hs - + testsuite/tests/driver/bytecode-object/BytecodeTest.hs - + testsuite/tests/driver/bytecode-object/Makefile - + testsuite/tests/driver/bytecode-object/all.T - + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object19.script - + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object25.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout - testsuite/tests/driver/dynamicToo/dynamicToo001/Makefile - testsuite/tests/driver/fat-iface/T22405/T22405.stdout - testsuite/tests/driver/fat-iface/T22405/T22405b.stdout - testsuite/tests/driver/fat-iface/fat011.stderr - testsuite/tests/driver/fat-iface/fat014.script - testsuite/tests/driver/implicit-dyn-too/Makefile - testsuite/tests/driver/linkwhole/Main.hs - testsuite/tests/driver/multipleHomeUnits/all.T - testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout - + testsuite/tests/driver/recomp022/A1.hs - + testsuite/tests/driver/recomp022/A2.hs - + testsuite/tests/driver/recomp022/A3.hs - + testsuite/tests/driver/recomp022/B.hs - + testsuite/tests/driver/recomp022/C.hs - + testsuite/tests/driver/recomp022/Makefile - + testsuite/tests/driver/recomp022/all.T - + testsuite/tests/driver/recomp022/recomp022a.stdout - + testsuite/tests/driver/recomp022/recomp022b.stdout - testsuite/tests/ghc-api/T10052/T10052.hs - testsuite/tests/ghc-api/T10942.hs - testsuite/tests/ghc-api/T8639_api.hs - testsuite/tests/ghc-api/annotations-literals/literals.hs - testsuite/tests/ghc-api/apirecomp001/myghc.hs - testsuite/tests/ghc-e/should_fail/T9930fail.stderr - testsuite/tests/ghc-e/should_fail/all.T - testsuite/tests/ghci.debugger/scripts/break022/all.T - testsuite/tests/ghci.debugger/scripts/break022/break022.script - testsuite/tests/ghci.debugger/scripts/break023/all.T - testsuite/tests/ghci.debugger/scripts/break023/break023.script - − testsuite/tests/ghci/linking/T11531.stderr - testsuite/tests/ghci/linking/dyn/T3372.hs - testsuite/tests/ghci/prog001/prog001.T - testsuite/tests/ghci/prog001/prog001.script - testsuite/tests/ghci/prog002/prog002.T - testsuite/tests/ghci/prog002/prog002.script - testsuite/tests/ghci/prog003/prog003.T - testsuite/tests/ghci/prog003/prog003.script - testsuite/tests/ghci/prog005/prog005.T - testsuite/tests/ghci/prog005/prog005.script - testsuite/tests/ghci/prog010/all.T - testsuite/tests/ghci/prog010/ghci.prog010.script - testsuite/tests/ghci/prog012/all.T - testsuite/tests/ghci/prog012/prog012.script - testsuite/tests/ghci/prog018/prog018.script - testsuite/tests/ghci/recompTHghci/all.T - testsuite/tests/ghci/recompTHghci/recompTHghci.script - testsuite/tests/ghci/scripts/T13869.script - testsuite/tests/ghci/scripts/T13997.script - testsuite/tests/ghci/scripts/T17669.script - testsuite/tests/ghci/scripts/T18330.script - testsuite/tests/ghci/scripts/T18330.stdout - testsuite/tests/ghci/scripts/T1914.script - testsuite/tests/ghci/scripts/T20217.script - testsuite/tests/ghci/scripts/T20587.script - testsuite/tests/ghci/scripts/T6105.script - testsuite/tests/ghci/scripts/T6106.script - testsuite/tests/ghci/scripts/T8042.script - testsuite/tests/ghci/scripts/T8042recomp.script - testsuite/tests/ghci/scripts/T8353.script - testsuite/tests/ghci/scripts/all.T - testsuite/tests/ghci/scripts/ghci038.script - testsuite/tests/ghci/scripts/ghci058.script - testsuite/tests/ghci/scripts/ghci063.script - − testsuite/tests/ghci/shell.hs - testsuite/tests/ghci/should_run/Makefile - testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T - testsuite/tests/ghci/should_run/T18064.script - testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T - testsuite/tests/ghci/should_run/UnliftedDataTypeInterp/unlifteddatatypeinterp.T - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - + testsuite/tests/hpc/ghc_ghci/hpc_ghci01.stdout - + testsuite/tests/hpc/ghc_ghci/hpc_ghci02.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T - testsuite/tests/indexed-types/should_fail/T14887.stderr - testsuite/tests/linear/should_fail/T19361.stderr - testsuite/tests/perf/compiler/Makefile - testsuite/tests/perf/compiler/MultiLayerModulesDefsGhci.script - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script - testsuite/tests/perf/compiler/all.T - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/rts/KeepCafsMain.hs - testsuite/tests/rts/T13676.script - testsuite/tests/rts/linker/T2615.hs - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T17673.stderr - testsuite/tests/simplCore/should_compile/T18078.stderr - testsuite/tests/simplCore/should_compile/T18995.stderr - testsuite/tests/simplCore/should_compile/T19890.stderr - testsuite/tests/simplCore/should_compile/T21948.stderr - testsuite/tests/simplCore/should_compile/T21960.stderr - testsuite/tests/simplCore/should_compile/T24808.stderr - − testsuite/tests/simplCore/should_compile/T25713.stderr - testsuite/tests/simplCore/should_compile/T4201.stdout - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplStg/should_compile/T22840.stderr - testsuite/tests/typecheck/no_skolem_info/T20232.stderr - testsuite/tests/typecheck/should_fail/T11672.stderr - testsuite/tests/typecheck/should_fail/T12373.stderr - testsuite/tests/typecheck/should_fail/T15807.stderr - testsuite/tests/typecheck/should_fail/T16074.stderr - testsuite/tests/typecheck/should_fail/T18357a.stderr - testsuite/tests/typecheck/should_fail/T19627.stderr - testsuite/tests/typecheck/should_fail/T21530a.stderr - testsuite/tests/typecheck/should_fail/VisFlag1.stderr - utils/check-exact/Parsers.hs - utils/check-exact/Preprocess.hs - utils/deriveConstants/Main.hs - utils/ghc-pkg/Main.hs - utils/iserv/iserv.cabal.in - 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/373fc0f2bd7e13cf2edb012d46bf61… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/373fc0f2bd7e13cf2edb012d46bf61… 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/fendor/dep-json] 5 commits: Add json output format
by Hannes Siebenhandl (＠fendor) 06 Oct '26

06 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC Commits: e4e060bf by fendor at 2026-10-06T19:14:32+02:00 Add json output format - - - - - 12d898ae by fendor at 2026-10-06T19:14:32+02:00 Add support for multiple home units - - - - - a0583e76 by fendor at 2026-10-06T19:14:32+02:00 Record OPTIONS_GHC in the `PreprocessingNode` This allows user to treat modules if they use -XTemplateHaskell, for example. - - - - - a08c93d7 by fendor at 2026-10-06T19:14:32+02:00 Deprecate doMkDependHS - - - - - 3d7db4f1 by fendor at 2026-10-06T19:14:32+02:00 Testsuite changes - - - - - 62 changed files: - + changelog.d/make-depends-json - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Utils/Json.hs - + docs/users_guide/make-depends-json-schema-1_0.json - docs/users_guide/separate_compilation.rst - ghc/Main.hs - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/driver/mkdepend/Makefile - testsuite/tests/driver/mkdepend/A.hs → testsuite/tests/driver/mkdepend/T24384/A.hs - testsuite/tests/driver/mkdepend/C.hs → testsuite/tests/driver/mkdepend/T24384/C.hs - testsuite/tests/driver/mkdepend/C.hs-boot → testsuite/tests/driver/mkdepend/T24384/C.hs-boot - testsuite/tests/driver/mkdepend/D.hs → testsuite/tests/driver/mkdepend/T24384/D.hs - testsuite/tests/driver/mkdepend/E.hs → testsuite/tests/driver/mkdepend/T24384/E.hs - testsuite/tests/driver/mkdepend/dep-internal/DepInternal.hs → testsuite/tests/driver/mkdepend/T24384/dep-internal/DepInternal.hs - testsuite/tests/driver/mkdepend/dep-internal/dep-internal.pkg → testsuite/tests/driver/mkdepend/T24384/dep-internal/dep-internal.pkg - testsuite/tests/driver/mkdepend/dep-public/DepPublic.hs → testsuite/tests/driver/mkdepend/T24384/dep-public/DepPublic.hs - testsuite/tests/driver/mkdepend/dep-public/dep-public.pkg → testsuite/tests/driver/mkdepend/T24384/dep-public/dep-public.pkg - testsuite/tests/driver/mkdepend/dep/Dep.hs → testsuite/tests/driver/mkdepend/T24384/dep/Dep.hs - testsuite/tests/driver/mkdepend/dep/dep.pkg → testsuite/tests/driver/mkdepend/T24384/dep/dep.pkg - testsuite/tests/driver/mkdepend/foo.h → testsuite/tests/driver/mkdepend/T24384/foo.h - testsuite/tests/driver/mkdepend/lib/B.hs → testsuite/tests/driver/mkdepend/T24384/lib/B.hs - + testsuite/tests/driver/mkdepend/T24384/lib/B.hs-boot - testsuite/tests/driver/mkdepend/preproc.sh → testsuite/tests/driver/mkdepend/T24384/preproc.sh - testsuite/tests/driver/mkdepend/T24384a.stdout - + testsuite/tests/driver/mkdepend/T24384b.stdout - + testsuite/tests/driver/mkdepend/T24384c.stdout - testsuite/tests/driver/mkdepend/all.T - + testsuite/tests/driver/mkdepend/format_json.sh - + testsuite/tests/driver/mkdepend/format_makefile.sh - + testsuite/tests/driver/mkdepend/mhu01/a/A/Base.hs - + testsuite/tests/driver/mkdepend/mhu01/a/A/Base.hs-boot - + testsuite/tests/driver/mkdepend/mhu01/a/A/TH.hs - + testsuite/tests/driver/mkdepend/mhu01/a/Util.hs - + testsuite/tests/driver/mkdepend/mhu01/b/B/Normal.hs - + testsuite/tests/driver/mkdepend/mhu01/b/B/Splice.hs - + testsuite/tests/driver/mkdepend/mhu01/b/Util.hs - + testsuite/tests/driver/mkdepend/mhu01/c/C.hs - + testsuite/tests/driver/mkdepend/mhu01/unitA - + testsuite/tests/driver/mkdepend/mhu01/unitB - + testsuite/tests/driver/mkdepend/mhu01/unitC - + testsuite/tests/driver/mkdepend/mhu02/A.hs - + testsuite/tests/driver/mkdepend/mhu02/B.hs - + testsuite/tests/driver/mkdepend/mhu02/pp.sh - + testsuite/tests/driver/mkdepend/mhu02/unitA - + testsuite/tests/driver/mkdepend/mhu02/unitB - + testsuite/tests/driver/mkdepend/mhu03/pkg/A.hs - + testsuite/tests/driver/mkdepend/mhu03/pkg/pp.sh - + testsuite/tests/driver/mkdepend/mhu03/unitA - + testsuite/tests/driver/mkdepend/mkdepend01.dep-json - + testsuite/tests/driver/mkdepend/mkdepend01.dep-makefile - + testsuite/tests/driver/mkdepend/mkdepend01/A.hs - + testsuite/tests/driver/mkdepend/mkdepend_mhu01.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu01.dep-makefile - + testsuite/tests/driver/mkdepend/mkdepend_mhu02.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu03.dep-json - testsuite/tests/perf/compiler/large-project/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0d76280e2cbde0b866d6b614abdb6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0d76280e2cbde0b866d6b614abdb6… 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/apk/tag-strict-bot] Fix a few tag inference bugs.
by Andreas Klebinger (＠AndreasK) 06 Oct '26

06 Oct '26

Andreas Klebinger pushed to branch wip/apk/tag-strict-bot at Glasgow Haskell Compiler / GHC Commits: 6a80ad60 by Andreas Klebinger at 2026-10-06T12:54:02+00:00 Fix a few tag inference bugs. * Treat bottoming functions and nullary join points as functions. * When generating bytecode don't rely on imported tag sigs. Fixes #27831, #27841 and #27842. - - - - - 23 changed files: - + changelog.d/T27831-bottoming-strict-field - + changelog.d/T27842-bytecode-imported-tags - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - + testsuite/tests/bytecode/T27842.hs - + testsuite/tests/bytecode/T27842.stdout - + testsuite/tests/bytecode/T27842A.hs - + testsuite/tests/bytecode/T27842N.hs - testsuite/tests/bytecode/all.T - testsuite/tests/simplStg/should_compile/all.T - + testsuite/tests/simplStg/should_compile/inferTags005.hs - + testsuite/tests/simplStg/should_compile/inferTags005.stderr - + testsuite/tests/simplStg/should_compile/inferTags006.hs - + testsuite/tests/simplStg/should_compile/inferTags006.stderr - + testsuite/tests/simplStg/should_run/InferTags007_A.hs - + testsuite/tests/simplStg/should_run/T27831.hs - + testsuite/tests/simplStg/should_run/T27831.stdout - + testsuite/tests/simplStg/should_run/T27857.hs - + testsuite/tests/simplStg/should_run/T27857.stdout - testsuite/tests/simplStg/should_run/all.T - + testsuite/tests/simplStg/should_run/inferTags007.hs - + testsuite/tests/simplStg/should_run/inferTags007.stdout Changes: ===================================== changelog.d/T27831-bottoming-strict-field ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27831 +mrs: !16719 +synopsis: + Fix a segfault that could occur when a bottoming function was stored in a strict field. +description: + This was happening when a function that always diverges (e.g. ``\_ -> error "..."``) was stored in a strict field, and the constructor was pattern matched on + in "nearby" code where the structure of the constructor application was still visible to GHC. ===================================== changelog.d/T27842-bytecode-imported-tags ===================================== @@ -0,0 +1,6 @@ +section: bytecode +issues: #27842 +mrs: !16719 +synopsis: + Fix a segfault caused by reusing interface files generated with + ``-fbyte-code-and-object-code`` for interpreter sessions using ``-fprefer-byte-code``. ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -334,9 +334,15 @@ a) Tags for let-bindings: b) When referencing ids from other modules the Cmm backend will try to put a proper tag on these references through various means. When doing analysis we usually predict these cases to improve precision of the analysis. - But to my knowledge the bytecode generator makes no such attempts so we must - not infer imported bindings as tagged. - This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + The bytecode generator gives fewer guarantees about what it tags. + So we simply assume it fails to tag binders, even in the cases where it does. + + This is handled in GHC.Stg.EnforceEpt.Types.argTagInfo + + Eventually we will want to update the Analysis and bco code gen to uphold and + take advantage of tag inference at least to some degree. But for now it's + not a perf benefit for interpreted code, and essentially only run to uphold + the "strict field invariant"/EPT Invariant described in EPT enforcement. -} @@ -359,7 +365,7 @@ enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply StgTag - let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds for_bytecode this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) @@ -414,12 +420,14 @@ inferTagExpr env (StgApp fun args) | isDeadEndAppSig (idDmdSig fun) (length args) = TagBottoming - | fun_arity == 0 -- Unknown arity => Thunk or unknown call + | not (isJoinId fun) -- zero arity join ids behave like functions NOT thunks. + , fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno -- Imported function with known return tag | Just (TagFun res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated + , not (te_bytecode env) -- #27842 = res_info -- Local function with known return tag @@ -593,7 +601,7 @@ initSig (bndr, StgRhsClosure _ _ _ bndrs _ _) {- Note [Bottom functions are TagBottoming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a function with two branches with one +If we have a function with two branches with one branch being bottom, and the other returning a tagged unboxed tuple what is the result? We give it TagBottoming! To answer why consider this function: @@ -603,21 +611,40 @@ foo x = case x of True -> (# True,True #) False -> undefined -The true branch is obviously tagged. The other branch isn't. -We want to treat the *result* of foo as tagged as well so that -the combination of the branches also is tagged if all non-bottom -branches are tagged. -This is safe because the function is still always called/entered as long -as it's applied to arguments. Since the function will never return we can give -it safely any tag sig we like. -So we give it TagBottoming, as it allows the combined tag sig of the case expression -to be the combination of all non-bottoming branches. +The true branch obviously returns tagged components. The other branch is bottom. +We want to treat the components in the *result* returned by foo as tagged. +Because at a call site like: + + case foo e of + (# x, y #) -> + case x of + ... + +Either `foo` will have evaluated undefined or blown up. Or we will bind x and y +to tagged pointers. A fact we take advantage of to optimize `case x of`. + +The rule is then simple. A combination of the alternatives of the same case has +tagged components if all non-bottom branches have tagged components. + +To represent the bottoming alternatives we use TagBottoming. Which says all it's +components are tagged. Now the same is true if we have: + +foo :: Bool -> (# Bool, Bool #) +foo x = case x of + True -> (# True,True #) + False -> willCrash x + +Where we want to check: -NB: After the analysis is done we go back to treating bottoming functions as -untagged to ensure they are evaluated as expected in code like: +* Is `willCrash x` bottom? +* If it is not are the returned components tagged? - case bottom_id of { ...} +For the first question we have to be careful about the notion of bottom we use. +I've got this wrong in the past, because a underapplied bottoming function will +return a *function* as result. Rather than being bottom. +If the function *is* bottom then we treat it the same we do undefined above. And +use TagBottoming as the tagInfo of the expression. Hence the title of the Note. -} ----------------------------- ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp) where @@ -13,7 +14,7 @@ import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id -import GHC.Types.Name +import GHC.Types.Name ( nameIsLocalOrFrom ) import GHC.Types.Unique.Supply import GHC.Types.Unique.FM import GHC.Types.RepType @@ -22,10 +23,7 @@ import GHC.Unit.Types import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) -import GHC.Core.Type - -import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (importedIdLFInfo) +import GHC.Core.Type ( definitelyLiftedType ) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -40,9 +38,39 @@ import GHC.Utils.Misc import GHC.Stg.EnforceEpt.Types import Control.Monad - -newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } - deriving (Functor, Monad, Applicative) +import GHC.Exts (oneShot) + +data RmContext = RmContext { rm_mod :: !Module, rm_interpreter :: !Bool } + +data RmState = RmState { rm_us :: !UniqSupply, rm_fvs :: IdSet, rm_sig_env :: !(UniqFM Id TagSig)} +newtype RM a = RM { unRM :: RmContext -> RmState -> (# RmState, a #) } + +instance Functor RM where + fmap f (RM x) = RM $ \env -> oneShot $ \state -> + let (# s1, x' #) = x env state + in (# s1, f x' #) + +instance Applicative RM where + (RM f) <*> (RM x) = RM $ oneShot $ \env -> oneShot $ \state -> + let (# s1,!f' #) = f env state + (# s2, x' #) = x env s1 + in (# s2, f' x' #) + pure x = RM $ \_ s -> (# s, x #) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +instance Monad RM where + RM x >>= f = RM $ oneShot $ \env -> oneShot $ \state -> + let (# s1, x' #) = x env state + in case (f x') of RM r -> r env s1 + +-- | runRM this_mod for_bytecode us fvs tag_env +runRM :: Module -> Bool -> UniqSupply -> RM a -> a +runRM mod for_bytecode us act = + case (unRM act) + (RmContext { rm_mod = mod, rm_interpreter = for_bytecode }) + (RmState { rm_us = us, rm_fvs = emptyVarSet, rm_sig_env = emptyUFM }) + of + (# _, r #) -> r ------------------------------------------------------------ -- Add cases around strict fields where required. @@ -107,30 +135,29 @@ when building the free variable list. -------------------------------- instance MonadUnique RM where - getUniqueSupplyM = RM $ do - (m, us, mod,lcls) <- get - let (us1, us2) = splitUniqSupply us - (put) (m,us2,mod,lcls) - return us1 + getUniqueSupplyM = RM $ \_ s -> + case splitUniqSupply (rm_us s) of + (us1, us2) -> (# s { rm_us = us2 }, us1 #) getMap :: RM (UniqFM Id TagSig) -getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) +getMap = RM $ \_ s -> (# s, rm_sig_env s #) setMap :: (UniqFM Id TagSig) -> RM () -setMap !m = RM $ do - (_,us,mod,lcls) <- get - put (m, us,mod,lcls) - -getMod :: RM Module -getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) +setMap !m = RM $ \_ s -> (# s { rm_sig_env = m }, () #) getFVs :: RM IdSet -getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) +getFVs = RM $ \_ s -> (# s, rm_fvs s #) setFVs :: IdSet -> RM () -setFVs !fvs = RM $ do - (tag_map,us,mod,_lcls) <- get - put (tag_map, us,mod,fvs) +setFVs !fvs = RM $ \_ s -> (# s { rm_fvs = fvs }, () #) + +getMod :: RM Module +getMod = RM $ \env s -> (# s, rm_mod env #) + +-- | When generating bytecode certain bindings might be untagged. So we have to +-- have a way to check for that. +getForBytecode :: RM Bool +getForBytecode = RM $ \env s -> (# s, rm_interpreter env #) -- Rewrite the RHS(s) while making the id and it's sig available -- to determine if things are tagged/need to be captured as FV. @@ -238,51 +265,26 @@ indicates a bug in the tag inference implementation. For this reason we assert that we are running in interactive mode if a lookup fails. -} isTagged :: Id -> RM Bool -isTagged v - -- See Note [Bottom functions are TagBottoming] - | isDeadEndId v = pure False - | otherwise = do +isTagged v = do + for_bytecode <- getForBytecode this_mod <- getMod - -- See Note [Tag inference for interactive contexts] - let lookupDefault v = assertPpr (isInteractiveModule this_mod) - (text "unknown Id:" <> ppr this_mod <+> ppr v) - (TagVal TagDunno) - case nameIsLocalOrFrom this_mod (idName v) of - True - | definitelyUnliftedType (idType v) - -- NB: v might be the Id of a representation-polymorphic join point, - -- so we shouldn't use isUnliftedType here. See T22212. - -> return True - | otherwise -> do -- Local binding - !s <- getMap - let !sig = lookupWithDefaultUFM s (lookupDefault v) v - return $ case sig of - TagFun _ -> True -- function closure is tagged - TagVal TagDunno -> False - TagVal TagEPT -> True - TagVal TagBottoming -> True - TagVal (TagTuple _) -> True -- Consider unboxed tuples tagged. - -- Imported - False -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case importedIdLFInfo v of - -- Function, applied not entered. - LFReEntrant {} - -> True - -- Thunks need to be entered. - LFThunk {} - -> False - -- LFCon means we already know the tag, and it's tagged. - LFCon {} - -> True - LFUnknown {} - -> False - LFUnlifted {} -- Unboxed, tagging irrelevant - -> True - LFLetNoEscape {} - -- Shouldn't be possible. I don't think we can export letNoEscapes - -> True + s <- getMap + let get_env_sig = lookupUFM s + massertPpr + -- Assert the env is complete for local lifted binders, which means either + -- - The binder is present in the env + -- - The binder is not a local lifted binder *or* comes from a ghci context + (isJust (get_env_sig v) + -- See Note [Tag inference for interactive contexts] + || isInteractiveModule this_mod + || not (nameIsLocalOrFrom this_mod (idName v)) + || not (definitelyLiftedType (idType v))) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + -- TODO: We could refactor the whole pass such that we also set id_tagSig + -- for every imported id. But this likely comes with a heavy allocation + -- overhead so for now we just ensure to use the same logic across analysis + -- and rewriter. + pure $! isTaggedInfo $ argTagInfo for_bytecode (get_env_sig v) (StgVarArg v) isArgTagged :: StgArg -> RM Bool @@ -299,11 +301,10 @@ mkLocalArgId id = do --------------------------- -rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] -rewriteTopBinds mod us binds = - let doBinds = mapM rewriteTop binds - - in evalState (unRM doBinds) (mempty, us, mod, mempty) +rewriteTopBinds :: Bool -- ^ Generating bytecode? + -> Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] +rewriteTopBinds for_bytecode mod us binds = + runRM mod for_bytecode us (mapM rewriteTop binds) rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -12,7 +12,7 @@ where import GHC.Prelude import GHC.Core.DataCon -import GHC.Core.Type (isUnliftedType) +import GHC.Core.Type (isUnliftedType, definitelyUnliftedType) import GHC.Types.Id import GHC.Stg.Syntax import GHC.Stg.EnforceEpt.TagSig as TagSig @@ -22,6 +22,7 @@ import GHC.Utils.Misc( zipWithEqual ) import GHC.Utils.Panic import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) {- ********************************************************************* * * @@ -97,31 +98,40 @@ lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of Just (TagVal _) -> Nothing Nothing -> Nothing --- | Look up a value-level tag for an argument: either from the env (where --- a function-typed argument flattens to TagEPT — its closure is tagged) --- or derived from information on the variable itself. -lookupInfo :: TagEnv p -> StgArg -> TagInfo -lookupInfo env (StgVarArg var) +-- | Look up a value-level tag. +-- +-- If the tag info is completely determined by Id info we use that tag. +-- If the tag info is dependent on the analysis/call site use the passed TagSig. +-- If the passed TagSig is Nothing we fall back to safe tag info based on id properties. +argTagInfo :: Bool -> (Maybe TagSig) -> StgArg -> TagInfo +{-# INLINE argTagInfo #-} -- Specialize for the call site. +argTagInfo _for_bytecode _env_sig (StgLitArg{}) = TagEPT +argTagInfo for_bytecode env_sig (StgVarArg var) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc , not for_bytecode = TagEPT - | isUnliftedType (idType var) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + | definitelyUnliftedType (idType var) = TagEPT -- Variables in the environment. A function binding flattens to TagEPT -- since a function closure pointer is properly tagged; its return info -- is not relevant when the function is used as a value. - | Just sig <- lookupVarEnv (te_env env) var + | Just sig <- env_sig = case sig of TagVal info -> info TagFun _ -> TagEPT - | Just lf_info <- idLFInfo_maybe var - , not for_bytecode - = case lf_info of +-- Always save defaults. + | lf_info <- importedIdLFInfo var -- will make up LFInfo if not present. + = if for_bytecode + then TagDunno -- See Note [EPT enforcement for interpreted code] in GHC.Stg.EnforceEpt + else + case lf_info of -- Function, tagged (with arity) LFReEntrant {} -> TagEPT @@ -138,13 +148,12 @@ lookupInfo env (StgVarArg var) -- Shouldn't be possible. I don't think we can export letNoEscapes LFLetNoEscape {} -> panic "LFLetNoEscape exported" - | otherwise - = TagDunno - where - for_bytecode = te_bytecode env - -lookupInfo _ (StgLitArg {}) - = TagEPT +-- | Get tag info using the environment. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env arg@(StgVarArg var) = + let env_sig = (lookupVarEnv (te_env env) var) + in argTagInfo (te_bytecode env) env_sig arg +lookupInfo _env (StgLitArg{}) = TagEPT isDunnoSig :: TagSig -> Bool isDunnoSig (TagVal TagDunno) = True ===================================== testsuite/tests/bytecode/T27842.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +-- Regression test for #27842. +-- +-- The basic rundown is this: +-- We produce one interface file, however we store information dependent on the +-- code generation method in the interface file. +-- +-- We happen to pick the native code information to store in the interface file. +-- +-- When we compile a module M this way, and then generate byte code for code +-- depending on M based on M.hi we will assume certain exported definitions are EPT +-- tagged, despite the interpreter doing no such thing. +-- +-- This then led to crashes in the interpreter. +-- +-- We test three kinds of imported definitions: +-- * mk uses fun, a function whose TagSig says its result is tagged. +-- * bar uses just_con, a value whose LFInfo says it is a constructor. +-- * baz uses gt_con, the same for a nullary constructor. +module Main where + +import T27842A (fun, just_con, gt_con) +import T27842N (S(..), use_S, M(..), use_M, N(..), use_N) + +mk :: Int -> S +mk x = case fun x of (# xs, _ #) -> S xs +{-# NOINLINE mk #-} + +bar :: M +bar = M just_con +{-# NOINLINE bar #-} + +baz :: N +baz = N gt_con +{-# NOINLINE baz #-} + +main :: IO () +main = do + print (use_S (mk 42)) + print (use_M bar) + print (use_N baz) ===================================== testsuite/tests/bytecode/T27842.stdout ===================================== @@ -0,0 +1,3 @@ +42 +42 +3 ===================================== testsuite/tests/bytecode/T27842A.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +module T27842A (fun, just_con, gt_con) where + +-- The native EPT run gives fun the TagSig TagFun[TagTuple[TagEPT, TagDunno]]: +fun :: Int -> (# [Int], Int #) +fun x = let xs = x : xs in (# xs, x #) +{-# NOINLINE fun #-} + +-- In native code a static constructor, in bytecode an unevaluated closure. +just_con :: Maybe Int +just_con = Just 42 +{-# NOINLINE just_con #-} + +-- The same for a nullary constructor. Without its pointer tag, the object code +-- in T27842N would take the LT alternative, so GT shows the difference. +gt_con :: Ordering +gt_con = GT +{-# NOINLINE gt_con #-} ===================================== testsuite/tests/bytecode/T27842N.hs ===================================== @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-byte-code-and-object-code #-} +-- We compile this module as native code, depending on A's interface file. +-- A itself is loaded into GHCi, despite it's interface file being generated based +-- on native code generation. +module T27842N (S(..), use_S, M(..), use_M, N(..), use_N) where + +data S = S ![Int] + +-- We take apart the strict constructor value and branch on the value in its field. +-- If the field content is not EPT this causes undefined behaviour. + +use_S :: S -> Int +use_S (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S #-} + +data M = M !(Maybe Int) + +use_M :: M -> Int +use_M (M m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_M #-} + +data N = N !Ordering + +use_N :: N -> Int +use_N (N o) = case o of { LT -> 1; EQ -> 2; GT -> 3 } +{-# NOINLINE use_N #-} ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -17,3 +17,12 @@ test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) test('T27001', [extra_files(['T27001.hs']), req_interp], run_command, ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) + +# Bytecode must not trust tag information from imported interfaces, which +# comes from native code (#27842): neither the TagSig of an imported function +# nor the LFInfo of an imported value (with and without constructor fields). +test('T27842', [extra_files(['T27842A.hs', 'T27842N.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter ' + '-fobject-code -fbyte-code-and-object-code -fwrite-byte-code -fprefer-byte-code ' + 'T27842.hs']) ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -25,5 +25,17 @@ test('inferTags003', [ only_ways(['optasm']), ], compile, ['-ddump-cmm -dno-typeable-binds -O']) test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) test('T27005b', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) +# Both f and the join point j should have a signature TagTuple[TagEPT, TagEPT] +test('inferTags005', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) +# The function needs to have a signature TagTuple[TagEPT, TagEPT] +test('inferTags006', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -fno-full-laziness -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/simplStg/should_compile/inferTags005.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt005 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- <TagTuple[TagEPT, TagEPT]]> +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Consider the case where rhs and something both represent a tag value of <TagTuple[TagEPT, TagEPT]]> +-- In this case we want `f` to also give rise to TagFun [TagTuple[TagEPT, TagEPT]]] + +-- To achieve this we have to recognize j as a zero-arity function equivalent +-- which is what this test checks. + +-- The payoff is in `g` `r` is then known to be tagged, so `S r` needs no eval. +-- Only an unboxed tuple result exposes this. + +-- We disable worker/wrapper and CPR so `f` matches more closely the tests source. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +f x y = case x of + 0 -> j + 1 -> j + _ -> (# B, B #) + where + j = (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags005.stderr ===================================== @@ -0,0 +1,2 @@ +TagTuple[TagEPT, TagEPT] +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_compile/inferTags006.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt006 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- TagBottoming +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Similar to inferTage005 we want to give `f` the signature: TagFun <TagTuple[TagEPT, TagEPT]]> +-- This requires us to give `j` a `TagFun[TagBottoming]` signature, which is safe because +-- either its execution will diverge, or the resulting tuple *will* have two +-- tagged values. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +-- This case-of-case is just here to be optimized into a nullary join point. +f x y = case (case x of { 0 -> False; 1 -> False; _ -> True }) of + False -> error ("f: bad input " ++ show x ++ " " ++ show y ++ " " ++ show (x*y)) + True -> (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags006.stderr ===================================== @@ -0,0 +1 @@ +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_run/InferTags007_A.hs ===================================== @@ -0,0 +1,20 @@ +-- We suppress arity and LfInfo with the option. +{-# OPTIONS_GHC -fomit-interface-pragmas #-} +module InferTags007_A (fun, caf, bot, con) where + +fun :: Int -> Int +fun x = x + 1 +{-# NOINLINE fun #-} + +-- A CAF/thunk +caf :: [Int] +caf = map (* 2) [1 .. 10] +{-# NOINLINE caf #-} + +bot :: Int -> Int +bot _ = error "bot called" +{-# NOINLINE bot #-} + +con :: Maybe Int +con = Just 42 +{-# NOINLINE con #-} ===================================== testsuite/tests/simplStg/should_run/T27831.hs ===================================== @@ -0,0 +1,35 @@ +-- Regression test for #27831: a bottoming function stored in a strict +-- constructor field. +-- +-- Different parts of the tag inference machinery didn't agree on weither or not +-- a bottoming function should be treated as a EPT value, leading to a segfault. +module Main (main) where + +import Control.Exception +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import System.Exit + +data T = MkT Int !(Int -> Int) + +t :: T +t = MkT 1 (\_ -> error "T27831") +{-# NOINLINE t #-} + +f :: () -> T +f _ = t +{-# OPAQUE f #-} + +main :: IO () +main = do + c <- getClosureData t + case c of + ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure + APClosure{} -> putStrLn "FAIL: APClosure" >> exitFailure + _ -> putStrLn "OK: not a thunk" + + case f () of MkT n _ -> print n + + r <- try (evaluate (case t of MkT _ g -> g 1)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/T27831.stdout ===================================== @@ -0,0 +1,3 @@ +OK: not a thunk +1 +OK: T27831 ===================================== testsuite/tests/simplStg/should_run/T27857.hs ===================================== @@ -0,0 +1,45 @@ +{-# LANGUAGE StrictData #-} +-- Regression test from #27857: We store a function that loops indefinitely +-- in a strict field. +module Main (main) where +import Control.Monad + +data Body + = BNone + | BStream ((Int -> IO ()) -> IO () -> IO ()) + | BIface (Int -> IO ()) + | BBuilder String + | BFile Int + +data Obj = Obj [String] Body Int + +newtype Resp = Resp Obj + +stream :: Int -> [String] -> ((Int -> IO ()) -> IO () -> IO ()) -> Resp +stream st hdr b = Resp $ Obj (show st : hdr) (BStream b) 0 + +noBody :: Int -> [String] -> Resp +noBody st hdr = Resp $ Obj (show st : hdr) BNone 0 + +infinite :: Resp +infinite = stream 200 ["text/plain"] body + where + body :: (Int -> IO ()) -> IO () -> IO () + body write flush = do + let go n = write n *> flush *> go (succ n) + go (0 :: Int) + +other :: Resp +other = noBody 404 [] + +name :: Body -> String +name b = case b of + BNone -> "None" + BStream _ -> "Stream" + BIface _ -> "Iface" + BBuilder _ -> "Builder" + BFile _ -> "File" + +main :: IO () +main = forM_ [("infinite", infinite), ("other", other)] $ \(n, Resp (Obj _ b _)) -> + putStrLn $ n ++ "=" ++ name b ===================================== testsuite/tests/simplStg/should_run/T27857.stdout ===================================== @@ -0,0 +1,2 @@ +infinite=Stream +other=None ===================================== testsuite/tests/simplStg/should_run/all.T ===================================== @@ -3,13 +3,15 @@ # extra run flags # expected process return value, if not zero -# Only compile with optimisation +# Only run optimised code, native and interpreted: +# We now generate bytecode from STG so we should test native and bytecode. def f( name, opts ): - opts.only_ways = ['optasm'] + opts.only_ways = ['optasm', 'ghci-opt'] setTestOpts(f) -test('T9291', normal, compile_and_run, ['']) +# Breakpoint ticks would break CSE which this tests. +test('T9291', [omit_ways(['ghci']), extra_hc_opts('-fno-break-points')], compile_and_run, ['']) test('T13536', normal, compile_and_run, ['']) test('T13536a', @@ -20,6 +22,16 @@ test('T13536a', test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a']) test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042']) -test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0']) -test('unpack_enum', normal, compile_and_run, ['']) -test('T27005a', normal, compile_and_run, ['']) + +# Depends on tag inference being similarly effective for bytecode which it is not yet. +test('T23783', omit_ghci, multimod_compile_and_run, ['T23783', '-O -v0']) + +# Requires UNPACK which needs -O +test('unpack_enum', omit_ways(['ghci']), compile_and_run, ['']) + +# Tests that tag inference optimizes well, which is not the case for bytecode or +# when we insert profiling ticks. +test('T27005a', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('T27831', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('inferTags007', [extra_files(['InferTags007_A.hs'])], multimod_compile_and_run, ['inferTags007', '-O -v0']) +test('T27857', normal, compile_and_run, ['']) ===================================== testsuite/tests/simplStg/should_run/inferTags007.hs ===================================== @@ -0,0 +1,109 @@ +{-# LANGUAGE MagicHash #-} +-- This test sanity checks the tag info we generate for imported binders which +-- have no real info in the .hi file. +-- +-- This is important to avoid running into cases where we optimistically +-- generated better information based on things like type than the +-- compiled code actually provided. For example GHCi doesn't ensure tagging +-- of constructors. +module Main (main) where + +import Control.Exception +import Control.Monad +import GHC.Exts (Addr#) +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import GHC.Internal.Control.Exception.Base (patError) +import System.Exit + +import qualified InferTags007_A as A + +data S a = S !a + +data P = MkP !(Addr# -> Int) + +-- Put the imported values into a strict field of a top level Con +con_top_fun :: S (Int -> Int) +con_top_fun = S A.fun +{-# NOINLINE con_top_fun #-} + +con_top_caf :: S [Int] +con_top_caf = S A.caf +{-# NOINLINE con_top_caf #-} + +con_top_bot :: S (Int -> Int) +con_top_bot = S A.bot +{-# NOINLINE con_top_bot #-} + +con_top_con :: S (Maybe Int) +con_top_con = S A.con +{-# NOINLINE con_top_con #-} + +con_top_pat :: P +con_top_pat = MkP patError +{-# NOINLINE con_top_pat #-} + +-- Put the imported values into a strict field of a Con inside a rhs +expr_fun :: () -> S (Int -> Int) +expr_fun _ = S A.fun +{-# OPAQUE expr_fun #-} + +expr_caf :: () -> S [Int] +expr_caf _ = S A.caf +{-# OPAQUE expr_caf #-} + +expr_bot :: () -> S (Int -> Int) +expr_bot _ = S A.bot +{-# OPAQUE expr_bot #-} + +expr_con :: () -> S (Maybe Int) +expr_con _ = S A.con +{-# OPAQUE expr_con #-} + +-- Actually use the field. +use_S_head :: S [Int] -> Int +use_S_head (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S_head #-} + +use_S_fromJust :: S (Maybe Int) -> Int +use_S_fromJust (S m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_S_fromJust #-} + +use_S_apply :: S (Int -> Int) -> Int +use_S_apply (S f) = f 1 +{-# NOINLINE use_S_apply #-} + +checkNotThunk :: String -> a -> IO () +checkNotThunk name x = do + c <- getClosureData x + case c of + ThunkClosure{} -> putStrLn ("FAIL: " ++ name ++ " is a thunk") >> exitFailure + APClosure{} -> putStrLn ("FAIL: " ++ name ++ " is an AP") >> exitFailure + _ -> pure () + +-- Pattern matching binds the field itself, so no selector thunk is involved. +checkField :: String -> S a -> IO () +checkField name (S x) = checkNotThunk name x +{-# NOINLINE checkField #-} + +main :: IO () +main = do + -- Check if the pointer in the strict field is a thunk. + checkField "con_top_caf" con_top_caf + checkField "con_top_fun" con_top_fun + checkField "con_top_bot" con_top_bot + checkField "con_top_con" con_top_con + case con_top_pat of MkP f -> checkNotThunk "con_top_pat" f + checkField "expr_caf" (expr_caf ()) + checkField "expr_fun" (expr_fun ()) + checkField "expr_bot" (expr_bot ()) + checkField "expr_con" (expr_con ()) + + -- Actually execute a case on the contents of the field. + print (use_S_head con_top_caf, use_S_head (expr_caf ())) + print (use_S_fromJust con_top_con, use_S_fromJust (expr_con ())) + print (use_S_apply con_top_fun, use_S_apply (expr_fun ())) + forM_ [con_top_bot, expr_bot ()] $ \s -> do + r <- try (evaluate (use_S_apply s)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/inferTags007.stdout ===================================== @@ -0,0 +1,5 @@ +(2,2) +(42,42) +(2,2) +OK: bot called +OK: bot called View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a80ad6082d30aa91e644b290b236a1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a80ad6082d30aa91e644b290b236a1… 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/substitution-via-mapper] Fixing perf regressions in T27336, T9872d, T14683
by Simon Peyton Jones (＠simonpj) 06 Oct '26

06 Oct '26

Simon Peyton Jones pushed to branch wip/substitution-via-mapper at Glasgow Haskell Compiler / GHC Commits: ad86061e by Simon Peyton Jones at 2026-10-06T16:21:03+01:00 Fixing perf regressions in T27336, T9872d, T14683 What caused each regression 1. T27336 and T9872d: mkKindCo lost its "kinds are equal ⇒ Refl" case when it moved into TyCo/Make.hs. As a result, toPhantomCo kept the whole type-family proof inside phantom UnivCos, which reached 22M coercion nodes on T27336. 2. T14683, first part: mkUnivCo lost its eqType short cut, which left reflexive phantom casts in place. 3. T14683, second part: isReflForAllCo used == instead of eqForAllVis. That turned a forall {a} vs forall a coercion into a real cast, and the cast caused the extra simplifier iteration. 4. T27336 residual: zonk_tcapp took mk as an unknown function, so each result thunk was one word bigger. {-# INLINE zonk_tcapp #-} fixed it. What changed - mkKindCo and mkUnivCo moved to GHC.Core.Coercion, with Note [mkKindCo and mkUnivCo] explaining why they live there. Make.hs gets them via Coercion.hs-boot, and I removed three unused declarations from that boot file. - ForAllTyFlag moved, with all its functions and its Outputable/Binary instances, from L.H.S.Specificity into GHC.Types.Var. That module also now holds: - eqForAllVis and cmpForAllVis, still re-exported from Compare - the new isCoreTyLamForAllTyFlag - the new cmpForAllTyFlagExactly - ForAllTyFlag has no Eq or Ord, so the compiler now checks that every comparison follows Note [Comparing visibility]. - IfaceForAllTyFlag is a new newtype in GHC.Iface.Type with exact Eq/Ord (via cmpForAllTyFlagExactly), which the interface deduplication table needs. Its Binary instance delegates to ForAllTyFlag's, so the .hi format is unchanged. - Eq (HieType a) is now hand-written, so that the public HIE API keeps its ForAllTyFlag field. Plus: - (FT2)/(FC7) covar-binder checks in mkForAllTy, assertGoodForAllCo and Lint now use isCoreTyLamForAllTyFlag. These checks are slightly weaker than before: they no longer catch an Inferred covar binder. - ty_co_match now compares visibilities with eqForAllVis. It's slightly more permissive, but consistent with eqType. - mkEtaForAllMCo now returns MRefl for any invisible flag. That matches what mkForAllCo produces now anyway. - Unchanged behaviour: comparisons against a fixed flag (in Type.hs, Tc/Gen/App.hs, Tc/Errors/Ppr.hs, Tc/TyCl/Instance.hs, and the Iface printing code) use the exact predicates, such as isInferredForAllTyFlag and isSpecifiedForAllTyFlag. They behave exactly as before. - - - - - 34 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/TyCo/Make.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Rep.hs-boot - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToIface.hs-boot - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Iface/Type.hs-boot - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Types/Var.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Specificity.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad86061ecbf755a53abd07f49b1c4d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad86061ecbf755a53abd07f49b1c4d8… 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