Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC
Commits:
5a4da0bb by Simon Peyton Jones at 2025-10-20T23:09:06+01:00
Wibble
- - - - -
1 changed file:
- compiler/GHC/HsToCore/Expr.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -482,7 +482,7 @@ dsExpr (HsStatic (_, whole_ty) expr@(L loc _))
static_rhs = mkCoreApps (Var make_static_id) [ Type ty, srcLoc, expr_ds ]
- ; emitStaticBinding static_id static_rhs
+ ; emitStaticBind static_id static_rhs
; return (Var static_id) }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a4da0bb5460887faa1cd86421113c9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a4da0bb5460887faa1cd86421113c9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed new branch wip/T24464 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24464
You're receiving this email because of your account on gitlab.haskell.org.
1
0
21 Oct '25
Cheng Shao pushed new branch wip/wasm-dyld-pie at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/wasm-dyld-pie
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: wasm: workaround WebKit bug in dyld
by Marge Bot (＠marge-bot) 21 Oct '25
by Marge Bot (＠marge-bot) 21 Oct '25
21 Oct '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c9b8465c by Cheng Shao at 2025-10-20T10:16:00-04:00
wasm: workaround WebKit bug in dyld
This patch works around a WebKit bug and allows dyld to run on WebKit
based platforms as well. See added note for detailed explanation.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
97a92a6d by Julian Ospald at 2025-10-20T12:50:34-04:00
Improve error handling in 'getPackageArchives'
When the library dirs in the package conf files are not set up correctly,
the JS linker will happily ignore such packages and not link against them,
although they're part of the link plan.
Fixes #26383
- - - - -
36ab7344 by Sven Tennie at 2025-10-20T12:50:34-04:00
Align coding style
Improve readability by using the same style for all constructor calls in
this function.
- - - - -
c4e6e0df by Sven Tennie at 2025-10-20T12:50:34-04:00
Reduce complexity by removing joins with mempty
ldArgs, cArgs and cppArgs are all `mempty`. Thus concatenating them adds
nothing but some complexity while reading the code.
- - - - -
8 changed files:
- compiler/GHC/StgToJS/Linker/Linker.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Libffi.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Common.hs
- hadrian/src/Settings/Builders/DeriveConstants.hs
- hadrian/src/Settings/Builders/Hsc2Hs.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MultiWayIf #-}
-----------------------------------------------------------------------------
-- |
@@ -666,12 +667,19 @@ renderLinkerStats s =
getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
-getPackageArchives cfg unit_env units =
- filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"
- | u <- units
- , p <- getInstalledPackageLibDirs ue_state u
- , l <- getInstalledPackageHsLibs ue_state u
- ]
+getPackageArchives cfg unit_env units = do
+ fmap concat $ forM units $ \u -> do
+ let archives = [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"
+ | p <- getInstalledPackageLibDirs ue_state u
+ , l <- getInstalledPackageHsLibs ue_state u
+ ]
+ foundArchives <- filterM doesFileExist archives
+ if | not (null archives)
+ , null foundArchives
+ -> do
+ throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u))
+ | otherwise
+ -> pure foundArchives
where
ue_state = ue_homeUnitState unit_env
=====================================
hadrian/src/Rules/Gmp.hs
=====================================
@@ -11,7 +11,7 @@ import Target
import Utilities
import Hadrian.BuildPath
import Hadrian.Expression
-import Settings.Builders.Common (cArgs, getStagedCCFlags)
+import Settings.Builders.Common (getStagedCCFlags)
-- | Build in-tree GMP library objects (if GmpInTree flag is set) and return
-- their paths.
@@ -125,8 +125,7 @@ gmpRules = do
cFlags <-
interpretInContext ctx $
mconcat
- [ cArgs
- , getStagedCCFlags
+ [ getStagedCCFlags
-- gmp symbols are only used by bignum logic in
-- ghc-internal and shouldn't be exported by the
-- ghc-internal shared library.
=====================================
hadrian/src/Rules/Libffi.hs
=====================================
@@ -130,17 +130,14 @@ fixLibffiMakefile top =
configureEnvironment :: Stage -> Action [CmdOption]
configureEnvironment stage = do
context <- libffiContext stage
- cFlags <- interpretInContext context $ mconcat
- [ cArgs
- , getStagedCCFlags ]
- ldFlags <- interpretInContext context ldArgs
+ cFlags <- interpretInContext context getStagedCCFlags
sequence [ builderEnvironment "CC" $ Cc CompileC stage
, builderEnvironment "CXX" $ Cc CompileC stage
- , builderEnvironment "AR" (Ar Unpack stage)
+ , builderEnvironment "AR" $ Ar Unpack stage
, builderEnvironment "NM" Nm
, builderEnvironment "RANLIB" Ranlib
, return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w"
- , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
+ , return . AddEnv "LDFLAGS" $ "-w" ]
-- Need the libffi archive and `trackAllow` all files in the build directory.
-- See [Libffi indicating inputs].
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -188,18 +188,16 @@ configureArgs cFlags' ldFlags' = do
values <- unwords <$> expr
not (null values) ?
arg ("--configure-option=" ++ key ++ "=" ++ values)
- cFlags = mconcat [ remove ["-Werror"] cArgs
- , getStagedCCFlags
+ cFlags = mconcat [ getStagedCCFlags
-- See https://github.com/snowleopard/hadrian/issues/523
, arg $ "-iquote"
, arg $ top -/- pkgPath pkg
, cFlags'
]
- ldFlags = ldArgs <> ldFlags'
mconcat
[ conf "CFLAGS" cFlags
- , conf "LDFLAGS" ldFlags
+ , conf "LDFLAGS" ldFlags'
, conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir
, conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir
, conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir
=====================================
hadrian/src/Settings/Builders/Common.hs
=====================================
@@ -5,7 +5,7 @@ module Settings.Builders.Common (
module Oracles.Setting,
module Settings,
module UserSettings,
- cIncludeArgs, ldArgs, cArgs, cppArgs, cWarnings,
+ cIncludeArgs, cWarnings,
packageDatabaseArgs, bootPackageDatabaseArgs,
getStagedCCFlags, wayCcArgs
) where
@@ -38,15 +38,6 @@ cIncludeArgs = do
, pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ]
, pure [ "-I" ++ unifyPath dir | dir <- depDirs ] ]
-ldArgs :: Args
-ldArgs = mempty
-
-cArgs :: Args
-cArgs = mempty
-
-cppArgs :: Args
-cppArgs = mempty
-
-- TODO: should be in a different file
cWarnings :: Args
cWarnings = mconcat
=====================================
hadrian/src/Settings/Builders/DeriveConstants.hs
=====================================
@@ -40,8 +40,7 @@ includeCcArgs :: Args
includeCcArgs = do
stage <- getStage
rtsPath <- expr $ rtsBuildPath stage
- mconcat [ cArgs
- , cWarnings
+ mconcat [ cWarnings
, prgFlags . ccProgram . tgtCCompiler <$> expr (targetStage Stage1)
, queryTargetTarget tgtUnregisterised ? arg "-DUSE_MINIINTERPRETER"
, arg "-Irts"
=====================================
hadrian/src/Settings/Builders/Hsc2Hs.hs
=====================================
@@ -50,7 +50,7 @@ getCFlags = do
autogen <- expr $ autogenPath context
let cabalMacros = autogen -/- "cabal_macros.h"
expr $ need [cabalMacros]
- mconcat [ remove ["-O"] (cArgs <> getStagedCCFlags)
+ mconcat [ remove ["-O"] getStagedCCFlags
-- Either "-E" is not part of the configured cpp args, or we can't add those args to invocations of things like this
-- ROMES:TODO: , prgFlags . cppProgram . tgtCPreprocessor <$> getStagedTargetConfig
, cIncludeArgs
@@ -64,6 +64,5 @@ getCFlags = do
getLFlags :: Expr [String]
getLFlags =
mconcat [ prgFlags . ccLinkProgram . tgtCCompilerLink <$> getStagedTarget
- , ldArgs
, getContextData ldOpts
, getContextData depLdOpts ]
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -670,7 +670,25 @@ class DyLD {
// Wasm memory & table
#memory = new WebAssembly.Memory({ initial: 1 });
+
#table = new WebAssembly.Table({ element: "anyfunc", initial: 1 });
+ // First free slot, might be invalid when it advances to #table.length
+ #tableFree = 1;
+ // See Note [The evil wasm table grower]
+ #tableGrowInstance = new WebAssembly.Instance(
+ new WebAssembly.Module(
+ new Uint8Array([
+ 0, 97, 115, 109, 1, 0, 0, 0, 1, 6, 1, 96, 1, 127, 1, 127, 2, 35, 1, 3,
+ 101, 110, 118, 25, 95, 95, 105, 110, 100, 105, 114, 101, 99, 116, 95,
+ 102, 117, 110, 99, 116, 105, 111, 110, 95, 116, 97, 98, 108, 101, 1,
+ 112, 0, 0, 3, 2, 1, 0, 7, 31, 1, 27, 95, 95, 103, 104, 99, 95, 119, 97,
+ 115, 109, 95, 106, 115, 102, 102, 105, 95, 116, 97, 98, 108, 101, 95,
+ 103, 114, 111, 119, 0, 0, 10, 11, 1, 9, 0, 208, 112, 32, 0, 252, 15, 0,
+ 11,
+ ])
+ ),
+ { env: { __indirect_function_table: this.#table } }
+ );
// __stack_pointer
#sp = new WebAssembly.Global(
@@ -715,6 +733,82 @@ class DyLD {
// Global STG registers
#regs = {};
+ // Note [The evil wasm table grower]
+ // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ // We need to grow the wasm table as we load shared libraries in
+ // wasm dyld. We used to directly call the table.grow() JS API,
+ // which works as expected in Firefox/Chrome, but unfortunately,
+ // WebKit's implementation of the table.grow() JS API is broken:
+ // https://bugs.webkit.org/show_bug.cgi?id=290681, which means that
+ // the wasm dyld simply does not work in WebKit-based browsers like
+ // Safari.
+ //
+ // Now, one simple workaround would be to avoid growing the table at
+ // all: just allocate a huge table upfront (current limitation
+ // agreed by all vendors is 10000000). To avoid unnecessary space
+ // waste on non-WebKit platforms, we could additionally check
+ // navigator.userAgent against some regexes and only allocate
+ // fixed-length table when there's no blink/gecko mention. But this
+ // is fragile and gross, and it's better to stick to a uniform code
+ // path for all browsers.
+ //
+ // Fortunately, it turns out the table.grow wasm instruction work as
+ // expected in WebKit! So we can invoke a wasm function that grows
+ // the table for us. But don't open a champagne yet, where would
+ // that wasm function come from? It can't be put into RTS, or even
+ // libc.so, because loading those libraries would require growing
+ // the table in the first place! Or perhaps, reserve a table upfront
+ // that's just large enough to load RTS and then we can access that
+ // function for subsequent table grows? But then we need to
+ // experiment for a reasonable initial size, and add a magic number
+ // here, which is also fragile and gross and not future-proof!
+ //
+ // So this special wasm function needs to live in a single wasm
+ // module, which is loaded before we load anything else. The full
+ // source code for this module is:
+ //
+ // (module
+ // (type (func (param i32) (result i32)))
+ // (import "env" "__indirect_function_table" (table 0 funcref))
+ // (export "__ghc_wasm_jsffi_table_grow" (func 0))
+ // (func (type 0) (param i32) (result i32)
+ // ref.null func
+ // local.get 0
+ // table.grow 0
+ // )
+ // )
+ //
+ // This module is 103 bytes so that we can inline its blob in dyld,
+ // and use the usually discouraged synchronous
+ // WebAssembly.Instance/WebAssembly.Module constructors to load it.
+ // On non-WebKit platforms, growing tables this way would introduce
+ // a bit of extra JS/Wasm interop overhead, which can be amplified
+ // as we used to call table.grow(1, foo) for every GOT.func item.
+ // Therefore, unless we're about to exceed the hard limit of table
+ // size, we now grow the table exponentially, and use bump
+ // allocation to calculate the table index to be returned.
+ // Exponential growth is only implemented to minimize the JS/Wasm
+ // interop overhead when calling __ghc_wasm_jsffi_table_grow;
+ // V8/SpiderMonkey/WebKit already do their own exponential growth of
+ // the table's backing buffer in their table growth logic.
+ //
+ // Invariants: n >= 0; when v is non-null, n === 1
+ #tableGrow(n, v) {
+ const prev_free = this.#tableFree;
+ if (prev_free + n > this.#table.length) {
+ const min_delta = prev_free + n - this.#table.length;
+ const delta = Math.max(min_delta, this.#table.length);
+ this.#tableGrowInstance.exports.__ghc_wasm_jsffi_table_grow(
+ this.#table.length + delta <= 10000000 ? delta : min_delta
+ );
+ }
+ if (v) {
+ this.#table.set(prev_free, v);
+ }
+ this.#tableFree += n;
+ return prev_free;
+ }
+
constructor({ args, rpc }) {
this.#rpc = rpc;
@@ -878,7 +972,7 @@ class DyLD {
// __memory_base & __table_base, different for each .so
let memory_base;
- let table_base = this.#table.grow(tableSize);
+ let table_base = this.#tableGrow(tableSize);
console.assert(tableP2Align === 0);
// libc.so is always the first one to be ever loaded and has VIP
@@ -982,7 +1076,7 @@ class DyLD {
if (this.exportFuncs[name]) {
this.#gotFunc[name] = new WebAssembly.Global(
{ value: "i32", mutable: true },
- this.#table.grow(1, this.exportFuncs[name])
+ this.#tableGrow(1, this.exportFuncs[name])
);
continue;
}
@@ -1033,7 +1127,7 @@ class DyLD {
if (this.#gotFunc[k]) {
const got = this.#gotFunc[k];
if (got.value === DyLD.#poison) {
- const idx = this.#table.grow(1, v);
+ const idx = this.#tableGrow(1, v);
got.value = idx;
} else {
this.#table.set(got.value, v);
@@ -1103,7 +1197,7 @@ class DyLD {
// Not in GOT.func yet, create the entry on demand
if (this.exportFuncs[sym]) {
console.assert(!this.#gotFunc[sym]);
- const addr = this.#table.grow(1, this.exportFuncs[sym]);
+ const addr = this.#tableGrow(1, this.exportFuncs[sym]);
this.#gotFunc[sym] = new WebAssembly.Global(
{ value: "i32", mutable: true },
addr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0d98f6fd494cbd34880c239af539a3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0d98f6fd494cbd34880c239af539a3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
20 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c9b8465c by Cheng Shao at 2025-10-20T10:16:00-04:00
wasm: workaround WebKit bug in dyld
This patch works around a WebKit bug and allows dyld to run on WebKit
based platforms as well. See added note for detailed explanation.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
1 changed file:
- utils/jsffi/dyld.mjs
Changes:
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -670,7 +670,25 @@ class DyLD {
// Wasm memory & table
#memory = new WebAssembly.Memory({ initial: 1 });
+
#table = new WebAssembly.Table({ element: "anyfunc", initial: 1 });
+ // First free slot, might be invalid when it advances to #table.length
+ #tableFree = 1;
+ // See Note [The evil wasm table grower]
+ #tableGrowInstance = new WebAssembly.Instance(
+ new WebAssembly.Module(
+ new Uint8Array([
+ 0, 97, 115, 109, 1, 0, 0, 0, 1, 6, 1, 96, 1, 127, 1, 127, 2, 35, 1, 3,
+ 101, 110, 118, 25, 95, 95, 105, 110, 100, 105, 114, 101, 99, 116, 95,
+ 102, 117, 110, 99, 116, 105, 111, 110, 95, 116, 97, 98, 108, 101, 1,
+ 112, 0, 0, 3, 2, 1, 0, 7, 31, 1, 27, 95, 95, 103, 104, 99, 95, 119, 97,
+ 115, 109, 95, 106, 115, 102, 102, 105, 95, 116, 97, 98, 108, 101, 95,
+ 103, 114, 111, 119, 0, 0, 10, 11, 1, 9, 0, 208, 112, 32, 0, 252, 15, 0,
+ 11,
+ ])
+ ),
+ { env: { __indirect_function_table: this.#table } }
+ );
// __stack_pointer
#sp = new WebAssembly.Global(
@@ -715,6 +733,82 @@ class DyLD {
// Global STG registers
#regs = {};
+ // Note [The evil wasm table grower]
+ // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ // We need to grow the wasm table as we load shared libraries in
+ // wasm dyld. We used to directly call the table.grow() JS API,
+ // which works as expected in Firefox/Chrome, but unfortunately,
+ // WebKit's implementation of the table.grow() JS API is broken:
+ // https://bugs.webkit.org/show_bug.cgi?id=290681, which means that
+ // the wasm dyld simply does not work in WebKit-based browsers like
+ // Safari.
+ //
+ // Now, one simple workaround would be to avoid growing the table at
+ // all: just allocate a huge table upfront (current limitation
+ // agreed by all vendors is 10000000). To avoid unnecessary space
+ // waste on non-WebKit platforms, we could additionally check
+ // navigator.userAgent against some regexes and only allocate
+ // fixed-length table when there's no blink/gecko mention. But this
+ // is fragile and gross, and it's better to stick to a uniform code
+ // path for all browsers.
+ //
+ // Fortunately, it turns out the table.grow wasm instruction work as
+ // expected in WebKit! So we can invoke a wasm function that grows
+ // the table for us. But don't open a champagne yet, where would
+ // that wasm function come from? It can't be put into RTS, or even
+ // libc.so, because loading those libraries would require growing
+ // the table in the first place! Or perhaps, reserve a table upfront
+ // that's just large enough to load RTS and then we can access that
+ // function for subsequent table grows? But then we need to
+ // experiment for a reasonable initial size, and add a magic number
+ // here, which is also fragile and gross and not future-proof!
+ //
+ // So this special wasm function needs to live in a single wasm
+ // module, which is loaded before we load anything else. The full
+ // source code for this module is:
+ //
+ // (module
+ // (type (func (param i32) (result i32)))
+ // (import "env" "__indirect_function_table" (table 0 funcref))
+ // (export "__ghc_wasm_jsffi_table_grow" (func 0))
+ // (func (type 0) (param i32) (result i32)
+ // ref.null func
+ // local.get 0
+ // table.grow 0
+ // )
+ // )
+ //
+ // This module is 103 bytes so that we can inline its blob in dyld,
+ // and use the usually discouraged synchronous
+ // WebAssembly.Instance/WebAssembly.Module constructors to load it.
+ // On non-WebKit platforms, growing tables this way would introduce
+ // a bit of extra JS/Wasm interop overhead, which can be amplified
+ // as we used to call table.grow(1, foo) for every GOT.func item.
+ // Therefore, unless we're about to exceed the hard limit of table
+ // size, we now grow the table exponentially, and use bump
+ // allocation to calculate the table index to be returned.
+ // Exponential growth is only implemented to minimize the JS/Wasm
+ // interop overhead when calling __ghc_wasm_jsffi_table_grow;
+ // V8/SpiderMonkey/WebKit already do their own exponential growth of
+ // the table's backing buffer in their table growth logic.
+ //
+ // Invariants: n >= 0; when v is non-null, n === 1
+ #tableGrow(n, v) {
+ const prev_free = this.#tableFree;
+ if (prev_free + n > this.#table.length) {
+ const min_delta = prev_free + n - this.#table.length;
+ const delta = Math.max(min_delta, this.#table.length);
+ this.#tableGrowInstance.exports.__ghc_wasm_jsffi_table_grow(
+ this.#table.length + delta <= 10000000 ? delta : min_delta
+ );
+ }
+ if (v) {
+ this.#table.set(prev_free, v);
+ }
+ this.#tableFree += n;
+ return prev_free;
+ }
+
constructor({ args, rpc }) {
this.#rpc = rpc;
@@ -878,7 +972,7 @@ class DyLD {
// __memory_base & __table_base, different for each .so
let memory_base;
- let table_base = this.#table.grow(tableSize);
+ let table_base = this.#tableGrow(tableSize);
console.assert(tableP2Align === 0);
// libc.so is always the first one to be ever loaded and has VIP
@@ -982,7 +1076,7 @@ class DyLD {
if (this.exportFuncs[name]) {
this.#gotFunc[name] = new WebAssembly.Global(
{ value: "i32", mutable: true },
- this.#table.grow(1, this.exportFuncs[name])
+ this.#tableGrow(1, this.exportFuncs[name])
);
continue;
}
@@ -1033,7 +1127,7 @@ class DyLD {
if (this.#gotFunc[k]) {
const got = this.#gotFunc[k];
if (got.value === DyLD.#poison) {
- const idx = this.#table.grow(1, v);
+ const idx = this.#tableGrow(1, v);
got.value = idx;
} else {
this.#table.set(got.value, v);
@@ -1103,7 +1197,7 @@ class DyLD {
// Not in GOT.func yet, create the entry on demand
if (this.exportFuncs[sym]) {
console.assert(!this.#gotFunc[sym]);
- const addr = this.#table.grow(1, this.exportFuncs[sym]);
+ const addr = this.#tableGrow(1, this.exportFuncs[sym]);
this.#gotFunc[sym] = new WebAssembly.Global(
{ value: "i32", mutable: true },
addr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9b8465c2c338176fcab9d197e9d31f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9b8465c2c338176fcab9d197e9d31f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Handle implications between x86 feature flags
by Marge Bot (＠marge-bot) 20 Oct '25
by Marge Bot (＠marge-bot) 20 Oct '25
20 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d4a9d6d6 by ARATA Mizuki at 2025-10-19T18:43:47+09:00
Handle implications between x86 feature flags
This includes:
* Multiple -msse* options can be specified
* -mavx implies -msse4.2
* -mavx2 implies -mavx
* -mfma implies -mavx
* -mavx512f implies -mavx2 and -mfma
* -mavx512{cd,er,pf} imply -mavx512f
Closes #24989
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
14 changed files:
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Platform.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/using.rst
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.asm
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.hs
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.asm
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/Config.hs
=====================================
@@ -29,9 +29,7 @@ data NCGConfig = NCGConfig
, ncgRegsGraph :: !Bool
, ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
, ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding
- , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions
- , ncgAvxEnabled :: !Bool
- , ncgAvx2Enabled :: !Bool
+ , ncgSseAvxVersion :: Maybe SseAvxVersion -- ^ (x86) SSE and AVX instructions
, ncgAvx512fEnabled :: !Bool
, ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions
, ncgDumpRegAllocStages :: !Bool
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -104,30 +104,32 @@ is32BitPlatform = do
platform <- getPlatform
return $ target32Bit platform
+-- These flags may be implied by other flags like -mfma or -mavx512f.
+-- See Note [Implications between X86 CPU feature flags] for details.
ssse3Enabled :: NatM Bool
ssse3Enabled = do
config <- getConfig
- return (ncgSseVersion config >= Just SSSE3)
+ return (ncgSseAvxVersion config >= Just SSSE3)
sse4_1Enabled :: NatM Bool
sse4_1Enabled = do
config <- getConfig
- return (ncgSseVersion config >= Just SSE4)
+ return (ncgSseAvxVersion config >= Just SSE4)
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
config <- getConfig
- return (ncgSseVersion config >= Just SSE42)
+ return (ncgSseAvxVersion config >= Just SSE42)
avxEnabled :: NatM Bool
avxEnabled = do
config <- getConfig
- return (ncgAvxEnabled config)
+ return (ncgSseAvxVersion config >= Just AVX1)
avx2Enabled :: NatM Bool
avx2Enabled = do
config <- getConfig
- return (ncgAvx2Enabled config)
+ return (ncgSseAvxVersion config >= Just AVX2)
cmmTopCodeGen
:: RawCmmDecl
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -1121,8 +1121,8 @@ movInstr config fmt =
= f
plat = ncgPlatform config
- avx = ncgAvxEnabled config
- avx2 = ncgAvx2Enabled config
+ avx = ncgSseAvxVersion config >= Just AVX1
+ avx2 = ncgSseAvxVersion config >= Just AVX2
avx512f = ncgAvx512fEnabled config
avx_move sFmt =
if isFloatScalarFormat sFmt
=====================================
compiler/GHC/Driver/Config/CmmToAsm.hs
=====================================
@@ -52,15 +52,18 @@ initNCGConfig dflags this_mod = NCGConfig
-- operations would change the precision and final result of what
-- would otherwise be the same expressions with respect to single or
-- double precision IEEE floating point computations.
- , ncgSseVersion =
- let v | sseVersion dflags < Just SSE2 = Just SSE2
- | otherwise = sseVersion dflags
+
+ -- ncgSseAvxVersion is set to the actual SSE/AVX version.
+ -- For example, -mfma does not set DynFlags's sseAvxVersion, but makes ncgSseAvxVersion >= AVX1.
+ -- See also Note [Implications between X86 CPU feature flags]
+ , ncgSseAvxVersion =
+ let v | isAvx2Enabled dflags = Just AVX2 -- -mavx512f does not set sseAvxVersion, but makes isAvx2Enabled true
+ | isAvxEnabled dflags = Just AVX1 -- -mfma does not set sseAvxVersion, but makes isAvxEnabled true
+ | otherwise = max (Just SSE2) (sseAvxVersion dflags)
in case platformArch (targetPlatform dflags) of
ArchX86_64 -> v
ArchX86 -> v
_ -> Nothing
- , ncgAvxEnabled = isAvxEnabled dflags
- , ncgAvx2Enabled = isAvx2Enabled dflags
, ncgAvx512fEnabled = isAvx512fEnabled dflags
, ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -447,10 +447,8 @@ data DynFlags = DynFlags {
interactivePrint :: Maybe String,
-- | Machine dependent flags (-m\<blah> stuff)
- sseVersion :: Maybe SseVersion,
+ sseAvxVersion :: Maybe SseAvxVersion,
bmiVersion :: Maybe BmiVersion,
- avx :: Bool,
- avx2 :: Bool,
avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions.
avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.
avx512f :: Bool, -- Enable AVX-512 instructions.
@@ -731,10 +729,8 @@ defaultDynFlags mySettings =
profAuto = NoProfAuto,
callerCcFilters = [],
interactivePrint = Nothing,
- sseVersion = Nothing,
+ sseAvxVersion = Nothing,
bmiVersion = Nothing,
- avx = False,
- avx2 = False,
avx512cd = False,
avx512er = False,
avx512f = False,
@@ -1548,22 +1544,28 @@ initPromotionTickContext dflags =
-- SSE, AVX, FMA
isSse3Enabled :: DynFlags -> Bool
-isSse3Enabled dflags = sseVersion dflags >= Just SSE3
+isSse3Enabled dflags = sseAvxVersion dflags >= Just SSE3 || isAvxEnabled dflags
isSsse3Enabled :: DynFlags -> Bool
-isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3
+isSsse3Enabled dflags = sseAvxVersion dflags >= Just SSSE3 || isAvxEnabled dflags
isSse4_1Enabled :: DynFlags -> Bool
-isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4
+isSse4_1Enabled dflags = sseAvxVersion dflags >= Just SSE4 || isAvxEnabled dflags
isSse4_2Enabled :: DynFlags -> Bool
-isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42
+isSse4_2Enabled dflags = sseAvxVersion dflags >= Just SSE42 || isAvxEnabled dflags
isAvxEnabled :: DynFlags -> Bool
-isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags
+isAvxEnabled dflags = sseAvxVersion dflags >= Just AVX1 || (isX86 && fma dflags) || isAvx512fEnabled dflags
+ where
+ -- -mfma can be used on multiple platforms, but -mavx is x86-only
+ isX86 = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> True
+ ArchX86 -> True
+ _ -> False
isAvx2Enabled :: DynFlags -> Bool
-isAvx2Enabled dflags = avx2 dflags || avx512f dflags
+isAvx2Enabled dflags = sseAvxVersion dflags >= Just AVX2 || isAvx512fEnabled dflags
isAvx512cdEnabled :: DynFlags -> Bool
isAvx512cdEnabled dflags = avx512cd dflags
@@ -1572,13 +1574,49 @@ isAvx512erEnabled :: DynFlags -> Bool
isAvx512erEnabled dflags = avx512er dflags
isAvx512fEnabled :: DynFlags -> Bool
-isAvx512fEnabled dflags = avx512f dflags
+isAvx512fEnabled dflags = avx512f dflags || avx512cd dflags || avx512er dflags || avx512pf dflags
isAvx512pfEnabled :: DynFlags -> Bool
isAvx512pfEnabled dflags = avx512pf dflags
isFmaEnabled :: DynFlags -> Bool
-isFmaEnabled dflags = fma dflags
+isFmaEnabled dflags = fma dflags || (isX86 && isAvx512fEnabled dflags)
+ where
+ -- -mfma is used on multiple platforms, but -mavx512f is x86-only
+ isX86 = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> True
+ ArchX86 -> True
+ _ -> False
+
+{- Note [Implications between X86 CPU feature flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Many X86 CPU feature flags (such as -mavx, -mfma or -msse4) imply other
+feature flags. In particular, there are straightforward linear implication
+structures:
+
+ 1. AVX2 -> AVX -> SSE4.2 -> SSE4 -> SSSE3 -> SSE3 -> SSE2 -> SSE1
+ 2. BMI2 -> BMI1
+
+together with other implications such as
+
+ 3. FMA -> AVX
+ 4. AVX512{CD,ED,PF} -> AVX512F -> AVX2
+
+
+We handle this as follows:
+
+ A. When parsing command line options into `DynFlags`, we record:
+ - an `SseAvxVersion` which gives the SSE/AVX level supported in
+ the total order (1),
+ - a `BmiVersion` for (2),
+ - whether FMA is enabled,
+ - various AVX512 flags saying which AVX512 extensions are supported
+
+ B. When converting these "raw" `DynFlags` into a `CmmConfig` for use
+ in code generator backends, we handle the remaining implications (3) (4),
+ e.g. if the user passed -mavx512f then we also set the `SseAvxVersion`
+ to `AVX2`.
+-}
-- -----------------------------------------------------------------------------
-- BMI2
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1684,25 +1684,28 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_faststrings)
------ Machine dependent (-m<blah>) stuff ---------------------------
+ -- See Note [Implications between X86 CPU feature flags]
, make_ord_flag defGhcFlag "msse" (noArg (\d ->
- d { sseVersion = Just SSE1 }))
+ d { sseAvxVersion = max (Just SSE1) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "msse2" (noArg (\d ->
- d { sseVersion = Just SSE2 }))
+ d { sseAvxVersion = max (Just SSE2) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "msse3" (noArg (\d ->
- d { sseVersion = Just SSE3 }))
+ d { sseAvxVersion = max (Just SSE3) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "mssse3" (noArg (\d ->
- d { sseVersion = Just SSSE3 }))
+ d { sseAvxVersion = max (Just SSSE3) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "msse4" (noArg (\d ->
- d { sseVersion = Just SSE4 }))
+ d { sseAvxVersion = max (Just SSE4) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "msse4.2" (noArg (\d ->
- d { sseVersion = Just SSE42 }))
+ d { sseAvxVersion = max (Just SSE42) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "mbmi" (noArg (\d ->
- d { bmiVersion = Just BMI1 }))
+ d { bmiVersion = max (Just BMI1) (bmiVersion d) }))
, make_ord_flag defGhcFlag "mbmi2" (noArg (\d ->
d { bmiVersion = Just BMI2 }))
- , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True }))
- , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True }))
+ , make_ord_flag defGhcFlag "mavx" (noArg (\d ->
+ d { sseAvxVersion = max (Just AVX1) (sseAvxVersion d) }))
+ , make_ord_flag defGhcFlag "mavx2" (noArg (\d ->
+ d { sseAvxVersion = max (Just AVX2) (sseAvxVersion d) }))
, make_ord_flag defGhcFlag "mavx512cd" (noArg (\d ->
d { avx512cd = True }))
, make_ord_flag defGhcFlag "mavx512er" (noArg (\d ->
=====================================
compiler/GHC/Platform.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Platform
, platformCConvNeedsExtension
, platformHasRTSLinker
, PlatformMisc(..)
- , SseVersion (..)
+ , SseAvxVersion (..)
, BmiVersion (..)
, wordAlignment
-- * SSE and AVX
@@ -264,14 +264,16 @@ platformHasRTSLinker p = case archOS_arch (platformArchOS p) of
-- Instruction sets
--------------------------------------------------
--- | x86 SSE instructions
-data SseVersion
+-- | x86 SSE and AVX instructions
+data SseAvxVersion
= SSE1
| SSE2
| SSE3
| SSSE3
| SSE4
| SSE42
+ | AVX1
+ | AVX2
deriving (Eq, Ord)
-- | x86 BMI (bit manipulation) instructions
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -28,6 +28,16 @@ Compiler
bound to variables. The very similar pattern ``Foo{bar = Bar{baz = 42}}``
will will not yet mark ``bar`` or ``baz`` as covered.
+- When multiple ``-msse*`` flags are given, the maximum version takes effect.
+ For example, ``-msse4.2 -msse2`` is now equivalent to ``-msse4.2``.
+ Previously, only the last flag took effect.
+
+- Some x86 architecture flags now imply other flags.
+ For example, :ghc-flag:`-mavx` now implies :ghc-flag:`-msse4.2`,
+ and :ghc-flag:`-mavx512f` now implies :ghc-flag:`-mfma`
+ in addition to :ghc-flag:`-mavx2`.
+ Refer to the users' guide for more details about each individual flag.
+
GHCi
~~~~
=====================================
docs/users_guide/using.rst
=====================================
@@ -1594,6 +1594,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-msse4.2`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX instructions.
@@ -1602,6 +1604,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mavx`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX2 instructions.
@@ -1610,6 +1614,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mavx512f`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX512-CD instructions.
@@ -1618,6 +1624,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mavx512f`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX512-ER instructions.
@@ -1626,6 +1634,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mavx2`, :ghc-flag:`-mfma`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX512-F instructions.
@@ -1634,6 +1644,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mavx512f`
+
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86_64 AVX512-PF instructions.
@@ -1690,6 +1702,7 @@ Some flags only make sense for particular target platforms.
:category: platform-options
:since: 9.14.1
+ :implies: :ghc-flag:`-msse3`
(x86 only) Use the SSSE3 instruction set to
implement some vector operations
@@ -1701,6 +1714,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-mssse3`
+
(x86 only) Use the SSE4 instruction set to
implement some floating point and bit operations(whether using the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`).
@@ -1710,6 +1725,8 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
+ :implies: :ghc-flag:`-msse4`
+
(x86 only, added in GHC 7.4.1) Use the SSE4.2 instruction set to
implement some floating point and bit operations,
whether using the :ref:`native code generator <native-code-gen>`
@@ -1747,6 +1764,7 @@ Some flags only make sense for particular target platforms.
:default: off by default, except for Aarch64 where it's on by default.
:since: 9.8.1
+ :implies: (on x86) :ghc-flag:`-mavx`
Use native FMA instructions to implement the fused multiply-add floating-point
operations of the form ``x * y + z``.
=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -12,3 +12,8 @@ test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True,
test('T18137', [when(opsys('darwin'), skip), only_ways(llvm_ways)], compile_grep_asm, ['hs', False, '-fllvm -split-sections'])
test('T24941', [only_ways(['optasm'])], compile, ['-fregs-graph'])
+
+test('msse-option-order', [unless(arch('x86_64') or arch('i386'), skip),
+ when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-msse4.2 -msse2'])
+test('mavx-should-enable-popcnt', [unless(arch('x86_64') or arch('i386'), skip),
+ when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-mavx'])
=====================================
testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.asm
=====================================
@@ -0,0 +1 @@
+popcnt(?![0-9])
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.hs
=====================================
@@ -0,0 +1,10 @@
+-- `-mavx` should imply `-msse4.2`.
+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/24989
+import Data.Bits
+
+{-# NOINLINE foo #-}
+foo :: Int -> Int
+foo x = 1 + popCount x
+
+main :: IO ()
+main = print (foo 42)
=====================================
testsuite/tests/codeGen/should_gen_asm/msse-option-order.asm
=====================================
@@ -0,0 +1 @@
+popcnt(?![0-9])
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_gen_asm/msse-option-order.hs
=====================================
@@ -0,0 +1,10 @@
+-- `-msse2 -msse4.2` and `-msse4.2 -msse2` should have the same effect.
+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/24989#note_587510
+import Data.Bits
+
+{-# NOINLINE foo #-}
+foo :: Int -> Int
+foo x = 1 + popCount x
+
+main :: IO ()
+main = print (foo 42)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4a9d6d6ec73b1851dec36cbf04d607…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4a9d6d6ec73b1851dec36cbf04d607…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T25262] Use template-haskell-lift/quasiquoter in boot libraries
by Teo Camarasu (＠teo) 20 Oct '25
by Teo Camarasu (＠teo) 20 Oct '25
20 Oct '25
Teo Camarasu pushed to branch wip/T25262 at Glasgow Haskell Compiler / GHC
Commits:
83bc16ae by Teo Camarasu at 2025-10-20T12:39:58+01:00
Use template-haskell-lift/quasiquoter in boot libraries
- - - - -
19 changed files:
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/Cabal
- libraries/bytestring
- libraries/containers
- libraries/exceptions
- libraries/filepath
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/os-string
- libraries/parsec
- libraries/text
- libraries/time
- libraries/unix
- utils/iserv/iserv.cabal.in
Changes:
=====================================
compiler/ghc.cabal.in
=====================================
@@ -118,7 +118,7 @@ Library
deepseq >= 1.4 && < 1.6,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- bytestring >= 0.11 && < 0.13,
+ bytestring >= 0.11 && < 0.14,
binary == 0.8.*,
time >= 1.4 && < 1.16,
containers >= 0.6.2.1 && < 0.9,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -36,7 +36,7 @@ Executable ghc
GHC.Driver.Session.Mode
Build-Depends: base >= 4 && < 5,
array >= 0.1 && < 0.6,
- bytestring >= 0.9 && < 0.13,
+ bytestring >= 0.9 && < 0.14,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
filepath >= 1.5 && < 1.6,
=====================================
hadrian/hadrian.cabal
=====================================
@@ -155,7 +155,7 @@ executable hadrian
, TypeFamilies
build-depends: Cabal >= 3.13 && < 3.17
, base >= 4.11 && < 5
- , bytestring >= 0.10 && < 0.13
+ , bytestring >= 0.10 && < 0.14
, containers >= 0.5 && < 0.9
-- N.B. directory >=1.3.9 as earlier versions are
-- afflicted by #24382.
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422
+Subproject commit bf964ddcc8e9c3c0a3ae46ab88c020046ac5e402
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit d984ad00644c0157bad04900434b9d36f23633c5
+Subproject commit 99ec2e9ef46c2e4cef7bf0d4505d66725ea0a842
=====================================
libraries/containers
=====================================
@@ -1 +1 @@
-Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721
+Subproject commit fef23e3d99597e9b34dd6fe6f1e7f49676b4bed3
=====================================
libraries/exceptions
=====================================
@@ -1 +1 @@
-Subproject commit b6c4290124eb1138358bf04ad9f33e67f6c5c1d8
+Subproject commit 6268676cddc3dfc164896bcb981054fe49d6ba91
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit e4cc73a60a7fa0111715292626fd0e1b01d4d39e
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -77,7 +77,7 @@ Library
build-depends: base >= 4.7 && < 4.23,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.6,
=====================================
libraries/ghc-compact/ghc-compact.cabal
=====================================
@@ -40,7 +40,7 @@ library
CPP
build-depends: base >= 4.9.0 && < 4.23,
- bytestring >= 0.10.6.0 && <0.13
+ bytestring >= 0.10.6.0 && <0.14
ghc-options: -Wall
exposed-modules: GHC.Compact
=====================================
libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
=====================================
@@ -53,7 +53,7 @@ executable ucd2haskell
Generator.WordEncoding
build-depends:
base >= 4.7 && < 5
- , bytestring >= 0.11 && < 0.13
+ , bytestring >= 0.11 && < 0.14
, directory >= 1.3.6 && < 1.4
, filepath >= 1.4.2 && < 1.6
, getopt-generics >= 0.13 && < 0.14
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -89,7 +89,7 @@ library
ghc-internal >= 9.1001.0 && <=@ProjectVersionForLib@.0,
ghc-prim >= 0.5.0 && < 0.14,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
filepath >= 1.4 && < 1.6,
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8
+Subproject commit c61650dc4cbbb4b7f5c8f96ccb23bb48dc5f580f
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
+Subproject commit 13b7bef9c40cd454a6e7b357dece7262e5276744
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit 552730e23e1fd2dae46a60d75138b8d173492462
+Subproject commit cbd35433d33a05676266d516e612b0aa31d5a5bc
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67
+Subproject commit b302347c7a1965a3e411bf885a1fc10b69f33744
=====================================
libraries/time
=====================================
@@ -1 +1 @@
-Subproject commit 507f50844802f1469ba6cadfeefd4e3fecee0416
+Subproject commit 4ae1bbd587bcbe0c643cefb00337ce85e0ff2507
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160
+Subproject commit 2076de9eabaeeca54e6e5715f26798248abaf67d
=====================================
utils/iserv/iserv.cabal.in
=====================================
@@ -33,7 +33,7 @@ Executable iserv
Build-Depends: array >= 0.5 && < 0.6,
base >= 4 && < 5,
binary >= 0.7 && < 0.11,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
ghci == @ProjectVersionMunged@
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83bc16aeb84439b31abb4895514a1fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83bc16aeb84439b31abb4895514a1fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T25262] Use template-haskell-lift/quasiquoter in boot libraries
by Teo Camarasu (＠teo) 20 Oct '25
by Teo Camarasu (＠teo) 20 Oct '25
20 Oct '25
Teo Camarasu pushed to branch wip/T25262 at Glasgow Haskell Compiler / GHC
Commits:
8e6fa892 by Teo Camarasu at 2025-10-20T12:39:41+01:00
Use template-haskell-lift/quasiquoter in boot libraries
- - - - -
22 changed files:
- + T
- + T.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/Cabal
- + libraries/addupstreams.py
- libraries/bytestring
- libraries/containers
- libraries/exceptions
- libraries/filepath
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/os-string
- libraries/parsec
- libraries/text
- libraries/time
- libraries/unix
- utils/iserv/iserv.cabal.in
Changes:
=====================================
T
=====================================
Binary files /dev/null and b/T differ
=====================================
T.hs
=====================================
@@ -0,0 +1,2 @@
+{-# LANGUAGE TemplateHaskell #-}
+main = pure $([|1|])
=====================================
compiler/ghc.cabal.in
=====================================
@@ -118,7 +118,7 @@ Library
deepseq >= 1.4 && < 1.6,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- bytestring >= 0.11 && < 0.13,
+ bytestring >= 0.11 && < 0.14,
binary == 0.8.*,
time >= 1.4 && < 1.16,
containers >= 0.6.2.1 && < 0.9,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -36,7 +36,7 @@ Executable ghc
GHC.Driver.Session.Mode
Build-Depends: base >= 4 && < 5,
array >= 0.1 && < 0.6,
- bytestring >= 0.9 && < 0.13,
+ bytestring >= 0.9 && < 0.14,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
filepath >= 1.5 && < 1.6,
=====================================
hadrian/hadrian.cabal
=====================================
@@ -155,7 +155,7 @@ executable hadrian
, TypeFamilies
build-depends: Cabal >= 3.13 && < 3.17
, base >= 4.11 && < 5
- , bytestring >= 0.10 && < 0.13
+ , bytestring >= 0.10 && < 0.14
, containers >= 0.5 && < 0.9
-- N.B. directory >=1.3.9 as earlier versions are
-- afflicted by #24382.
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422
+Subproject commit bf964ddcc8e9c3c0a3ae46ab88c020046ac5e402
=====================================
libraries/addupstreams.py
=====================================
@@ -0,0 +1,135 @@
+#!/usr/bin/env python3
+
+from pathlib import Path
+import subprocess
+import logging
+import re
+
+logging.basicConfig(level=logging.INFO)
+
+IGNORE = 1 # ignore submodule
+GITHUB_HASKELL = 2 # in the haskell github org
+ORIGIN = 3 # upstream remote == origin remote
+
+def github(owner: str, name: str) -> str:
+ return f'https://github.com/{owner}/{name}'
+
+def github_haskell(name: str) -> str:
+ return github('haskell', name)
+
+def gitlab_ssh(owner: str, name: str) -> str:
+ return f'git@gitlab.haskell.org:{owner}/{name}'
+
+upstreams = {
+ '.arc-linters/arcanist-external-json-linter': IGNORE,
+ 'libffi-tarballs': IGNORE,
+ 'libraries/array': GITHUB_HASKELL,
+ 'libraries/binary': GITHUB_HASKELL,
+ 'libraries/bytestring': GITHUB_HASKELL,
+ 'libraries/Cabal': GITHUB_HASKELL,
+ 'libraries/containers': GITHUB_HASKELL,
+ 'libraries/deepseq': GITHUB_HASKELL,
+ 'libraries/directory': GITHUB_HASKELL,
+ 'libraries/file-io': GITHUB_HASKELL,
+ 'libraries/filepath': GITHUB_HASKELL,
+ 'libraries/ghc-bignum/gmp/gmp-tarballs': ORIGIN,
+ 'libraries/ghc-internal/gmp/gmp-tarballs': ORIGIN,
+ 'libraries/haskeline': GITHUB_HASKELL,
+ 'libraries/hpc': ORIGIN,
+ 'libraries/integer-gmp/gmp/gmp-tarballs': ORIGIN,
+ 'libraries/mtl': GITHUB_HASKELL,
+ 'libraries/os-string': GITHUB_HASKELL,
+ 'libraries/parallel': GITHUB_HASKELL,
+ 'libraries/parsec': GITHUB_HASKELL,
+ 'libraries/pretty': GITHUB_HASKELL,
+ 'libraries/primitive': GITHUB_HASKELL,
+ 'libraries/process': GITHUB_HASKELL,
+ 'libraries/semaphore-compat': ORIGIN,
+ 'libraries/stm': GITHUB_HASKELL,
+ 'libraries/terminfo': GITHUB_HASKELL,
+ 'libraries/text': GITHUB_HASKELL,
+ 'libraries/time': GITHUB_HASKELL,
+ 'libraries/transformers': IGNORE, # darcs mirror
+ 'libraries/unix': GITHUB_HASKELL,
+ 'libraries/Win32': GITHUB_HASKELL,
+ 'nofib': 'https://gitlab.haskell.org/ghc/nofib',
+ 'utils/hpc': GITHUB_HASKELL,
+ 'utils/haddock': GITHUB_HASKELL,
+}
+
+all_submods = [
+ line.split()[1]
+ for line in subprocess.check_output(['git', 'submodule'], encoding='UTF-8').split('\n')
+ if len(line.split()) > 0
+]
+
+packages = {
+ line.split()[0]: line.split()[3]
+ for line in open('packages').read().split('\n')
+ if not line.startswith('#')
+ if len(line.split()) == 4
+ if line.split()[3] != '-'
+}
+
+def get_remote_url(submod: str, remote: str):
+ p = subprocess.run(['git', '-C', submod, 'remote', 'get-url', remote],
+ encoding='UTF-8',
+ stdout=subprocess.PIPE,
+ stderr=subprocess.DEVNULL)
+ if p.returncode == 0:
+ return p.stdout
+ else:
+ return None
+
+def add_remote(submod: str, remote: str, url: str):
+ old_url = get_remote_url(submod, remote)
+ if old_url is None:
+ logging.info(f'{submod}: adding remote {remote} = {url}')
+ subprocess.call(['git', '-C', submod, 'remote', 'add', remote, url])
+ elif old_url == url:
+ return
+ else:
+ logging.info(f'{submod}: updating remote {remote} = {url}')
+ subprocess.call(['git', '-C', submod, 'remote', 'set-url', remote, url])
+
+ #update_remote(submod, remote)
+
+def update_remote(submod: str, remote: str):
+ subprocess.check_call(['git', '-C', submod, 'remote', 'update', remote])
+
+def main():
+ for submod in all_submods:
+ print(submod)
+ upstream = None
+ if submod in upstreams:
+ upstream = upstreams[submod]
+ elif submod in packages:
+ upstream = packages[submod]
+
+ if upstream == ORIGIN:
+ upstream = subprocess.check_output(['git', '-C', submod, 'remote', 'get-url', 'origin'], encoding='UTF-8').strip()
+ elif upstream == GITHUB_HASKELL:
+ upstream = github_haskell(Path(submod).name)
+ elif upstream == IGNORE:
+ continue
+
+ if upstream is None:
+ print(f'Unknown upstream for {submod}')
+ raise ValueError('unknown upstream')
+ else:
+ print(f'Upstream of {submod} is {upstream}')
+ add_remote(submod, 'upstream', upstream)
+
+ origin = get_remote_url(submod, 'origin')
+ m = re.match('https://gitlab.haskell.org/(.*)', origin)
+ if m is not None:
+ push = f'git@gitlab.haskell.org:{m.group(1)}'
+ print(f'origin-push of {submod} is {push}')
+ add_remote(submod, 'origin-push', push)
+
+ name = Path(submod).name
+ add_remote(submod, 'teo', f'git@github.com:TeofilC/{name}')
+
+if __name__ == '__main__':
+ main()
+
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit d984ad00644c0157bad04900434b9d36f23633c5
+Subproject commit 99ec2e9ef46c2e4cef7bf0d4505d66725ea0a842
=====================================
libraries/containers
=====================================
@@ -1 +1 @@
-Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721
+Subproject commit fef23e3d99597e9b34dd6fe6f1e7f49676b4bed3
=====================================
libraries/exceptions
=====================================
@@ -1 +1 @@
-Subproject commit b6c4290124eb1138358bf04ad9f33e67f6c5c1d8
+Subproject commit 6268676cddc3dfc164896bcb981054fe49d6ba91
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit e4cc73a60a7fa0111715292626fd0e1b01d4d39e
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -77,7 +77,7 @@ Library
build-depends: base >= 4.7 && < 4.23,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.6,
=====================================
libraries/ghc-compact/ghc-compact.cabal
=====================================
@@ -40,7 +40,7 @@ library
CPP
build-depends: base >= 4.9.0 && < 4.23,
- bytestring >= 0.10.6.0 && <0.13
+ bytestring >= 0.10.6.0 && <0.14
ghc-options: -Wall
exposed-modules: GHC.Compact
=====================================
libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
=====================================
@@ -53,7 +53,7 @@ executable ucd2haskell
Generator.WordEncoding
build-depends:
base >= 4.7 && < 5
- , bytestring >= 0.11 && < 0.13
+ , bytestring >= 0.11 && < 0.14
, directory >= 1.3.6 && < 1.4
, filepath >= 1.4.2 && < 1.6
, getopt-generics >= 0.13 && < 0.14
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -89,7 +89,7 @@ library
ghc-internal >= 9.1001.0 && <=@ProjectVersionForLib@.0,
ghc-prim >= 0.5.0 && < 0.14,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
filepath >= 1.4 && < 1.6,
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8
+Subproject commit c61650dc4cbbb4b7f5c8f96ccb23bb48dc5f580f
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
+Subproject commit 13b7bef9c40cd454a6e7b357dece7262e5276744
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit 552730e23e1fd2dae46a60d75138b8d173492462
+Subproject commit cbd35433d33a05676266d516e612b0aa31d5a5bc
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67
+Subproject commit b302347c7a1965a3e411bf885a1fc10b69f33744
=====================================
libraries/time
=====================================
@@ -1 +1 @@
-Subproject commit 507f50844802f1469ba6cadfeefd4e3fecee0416
+Subproject commit 4ae1bbd587bcbe0c643cefb00337ce85e0ff2507
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160
+Subproject commit 2076de9eabaeeca54e6e5715f26798248abaf67d
=====================================
utils/iserv/iserv.cabal.in
=====================================
@@ -33,7 +33,7 @@ Executable iserv
Build-Depends: array >= 0.5 && < 0.6,
base >= 4 && < 5,
binary >= 0.7 && < 0.11,
- bytestring >= 0.10 && < 0.13,
+ bytestring >= 0.10 && < 0.14,
containers >= 0.5 && < 0.9,
deepseq >= 1.4 && < 1.6,
ghci == @ProjectVersionMunged@
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e6fa8924232c55a6e7555fe057ff21…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e6fa8924232c55a6e7555fe057ff21…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ani/kill-popErrCtxt] 2 commits: remote tcl_in_gen_code
by Apoorv Ingle (＠ani) 20 Oct '25
by Apoorv Ingle (＠ani) 20 Oct '25
20 Oct '25
Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC
Commits:
cce16183 by Apoorv Ingle at 2025-10-15T16:30:04+08:00
remote tcl_in_gen_code
- - - - -
cb15fefa by Apoorv Ingle at 2025-10-20T18:54:06+08:00
kill popErrCtxt
- - - - -
11 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -676,22 +676,21 @@ data SrcCodeOrigin
= OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression
| OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
| OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints
+ | PopErrCtxt -- A hint for typechecker to pop
+ -- the top of the error context stack
+ -- Does not presist post renaming phase
+ -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
+ -- in `GHC.Tc.Gen.Do`
data XXExprGhcRn
= ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages
, xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing
}
- | PopErrCtxt -- A hint for typechecker to pop
- {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack
- -- Does not presist post renaming phase
- -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
- -- in `GHC.Tc.Gen.Do`
| HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector
-- See Note [Non-overloaded record field selectors] and
-- Note [Record selectors in the AST]
-
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original expression and
-- expanded expressions.
@@ -713,6 +712,12 @@ mkExpandedStmt
mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
, xrn_expanded = eExpr })
+mkExpandedLastStmt
+ :: HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedLastStmt eExpr = XExpr (ExpandedThingRn { xrn_orig = PopErrCtxt
+ , xrn_expanded = eExpr })
+
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
@@ -1083,11 +1088,11 @@ instance Outputable SrcCodeOrigin where
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
OrigPat x -> ppr_builder "<OrigPat>:" x
+ PopErrCtxt -> text "<PopErrCtxt>"
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
- ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
ppr (HsRecSelRn f) = pprPrefixOcc f
instance Outputable XXExprGhcTc where
@@ -1133,7 +1138,6 @@ ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
-ppr_infix_expr_rn (PopErrCtxt a) = ppr_infix_expr a
ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -1233,7 +1237,6 @@ hsExprNeedsParens prec = go
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing
- go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a
go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: SrcCodeOrigin -> Bool
@@ -1286,7 +1289,6 @@ isAtomicHsExpr (XExpr x)
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
- go_x_rn (PopErrCtxt a) = isAtomicHsExpr a
go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1747,7 +1747,6 @@ repE e@(XExpr (ExpandedThingRn o x))
else repE e }
| otherwise
= notHandled (ThExpressionForm e)
-repE (XExpr (PopErrCtxt e)) = repE e
repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x))
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -951,10 +951,10 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside
, text "arg: " <+> ppr (arg, arg_no)
, text "arg_loc:" <+> ppr arg_loc
, text "fun:" <+> ppr fun
- , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
- UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y
- ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y)
- (take 4 (zip err_ctx err_ctx_msg)))
+ -- , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
+ -- UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y
+ -- ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y)
+ -- (take 4 (zip err_ctx err_ctx_msg)))
])
; if in_generated_code
then updCtxtForArg (locA arg_loc) arg $
@@ -968,10 +968,10 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside
do setSrcSpan l $
addExprCtxt e $
thing_inside
- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above
- thing_inside
+ -- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above
+ -- thing_inside
updCtxtForArg (UnhelpfulSpan {}) _ thing_inside = -- See 2.ii above
- do setInUserCode $
+ do -- setInUserCode $
thing_inside
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -81,7 +81,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))]
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField body))
+ = return $ L sloc (mkExpandedLastStmt (HsPar noExtField body))
| SyntaxExprRn ret <- ret_expr -- We have unfortunately lost the location on the return function :(
--
@@ -89,7 +89,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))]
-- return e ~~> return e
-- to make T18324 work
= do let expansion = L body_loc (genHsApp ret body)
- return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion))
+ return $ L sloc (mkExpandedLastStmt (HsPar noExtField expansion))
expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _))
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ wrapNoSpan $ unLoc e -- Span is set because of statement loc
+ [ e -- Span is set because of statement loc
, expand_stmts_expr ]
return $ L loc (mkExpandedStmt stmt doFlavour expansion)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
+import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types hiding (HoleError)
@@ -665,9 +666,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
; (ds_expr, ds_res_ty, err_msg)
<- expandRecordUpd record_expr possible_parents rbnds res_ty
- ; addErrCtxt err_msg $
- updLclCtxt setLclCtxtInGenCode $
- -- setInGeneratedCode (OrigExpr expr) $
+ ; addExpansionErrCtxt (OrigExpr expr) err_msg $
do { -- Typecheck the expanded expression.
expr' <- tcExpr ds_expr (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
@@ -722,7 +721,7 @@ tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
-tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty
+tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty
tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
tcExpr (HsUntypedSplice splice _) res_ty
@@ -757,14 +756,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
-}
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-
-tcXExpr (PopErrCtxt e) res_ty
- = do popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- addExprCtxt e $
- tcExpr e res_ty
-
tcXExpr (ExpandedThingRn o e) res_ty
- = setInGeneratedCode o $
+ = addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $
-- e is the expanded expression of o, so we need to set the error ctxt to generated
-- see Note [Error Context Stack] in `GHC.Tc.Type.LclEnv`
mkExpandedTc o <$> -- necessary for hpc ticks
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
+import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
import GHC.Tc.Types.Constraint( WantedConstraints )
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
@@ -269,7 +270,6 @@ splitHsApps e = go e noSrcSpan []
-- and its hard to say exactly what that is
: EWrap (EExpand e)
: args )
- go (XExpr (PopErrCtxt fun)) lspan args = go fun lspan args
-- look through PopErrCtxt (cf. T17594f) we do not want to lose the opportunity of calling tcEValArgQL
-- unlike HsPar, it is okay to forget about the PopErrCtxts as it does not persist over in GhcTc land
@@ -471,9 +471,8 @@ tcInferAppHead_maybe fun =
case fun of
HsVar _ nm -> Just <$> tcInferId nm
XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f
- XExpr (ExpandedThingRn o e) -> Just <$> (setInGeneratedCode o $ -- We do not want to instantiate c.f. T19167
- tcExprSigma False e)
- XExpr (PopErrCtxt e) -> tcInferAppHead_maybe e
+ XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- We do not want to instantiate c.f. T19167
+ tcExprSigma False e)
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Tc.Gen.Bind
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
+import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
import GHC.Tc.Types.Evidence
import GHC.Rename.Env ( irrefutableConLikeTc )
@@ -404,9 +405,9 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
; return (HsDo res_ty doExpr (L l stmts')) }
else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
; let orig = HsDo noExtField doExpr ss
- ; setInGeneratedCode (OrigExpr orig) $ do
- { e' <- tcMonoLExpr expanded_expr res_ty
- ; return (mkExpandedExprTc orig (unLoc e'))}
+ ; addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $
+ do { e' <- tcMonoLExpr expanded_expr res_ty
+ ; return (mkExpandedExprTc orig (unLoc e'))}
}
}
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -4,7 +4,7 @@
{-# LANGUAGE UndecidableInstances #-}
module GHC.Tc.Types.ErrCtxt
- ( ErrCtxt (..), ErrCtxtMsg(..), srcCodeOriginErrCtxMsg
+ ( ErrCtxt (..), ErrCtxtMsg(..), ErrCtxtMsgM, CodeSrcFlag (..), srcCodeOriginErrCtxMsg
, UserSigType(..), FunAppCtxtFunArg(..)
, TyConInstFlavour(..)
)
@@ -48,9 +48,11 @@ import qualified Data.List.NonEmpty as NE
--------------------------------------------------------------------------------
+type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)
+
-- | Additional context to include in an error message, e.g.
-- "In the type signature ...", "In the ambiguity check for ...", etc.
-data ErrCtxt = UserCodeCtxt (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg))
+data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM
-- Monadic so that we have a chance
-- to deal with bound type variables just before error
-- message construction
@@ -58,11 +60,9 @@ data ErrCtxt = UserCodeCtxt (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg))
-- Bool: True <=> this is a landmark context; do not
-- discard it when trimming for display
- | ExpansionCodeCtxt SrcCodeOrigin
- -- The payload is a SrcCodeOrigin because it is used to generate
- -- 1. The CtOrigin for CtLoc, and
- -- 2. ErrCtxtMsg in error messages
-
+data CodeSrcFlag = VanillaUserSrcCode
+ | LandmarkUserSrcCode
+ | ExpansionCodeCtxt SrcCodeOrigin
--------------------------------------------------------------------------------
-- Error message contexts
@@ -233,3 +233,4 @@ srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg
srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e
srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s)
srcCodeOriginErrCtxMsg (OrigPat p) = PatCtxt p
+srcCodeOriginErrCtxMsg (PopErrCtxt) = error "Shouldn't happen srcCodeOriginErr"
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -25,8 +25,6 @@ module GHC.Tc.Types.LclEnv (
, setLclEnvSrcCodeOrigin
, setLclCtxtSrcCodeOrigin
, lclEnvInGeneratedCode
- , setLclCtxtInGenCode
- , setLclCtxtInUserCode
, addLclEnvErrCtxt
@@ -38,7 +36,7 @@ module GHC.Tc.Types.LclEnv (
import GHC.Prelude
-import GHC.Hs ( SrcCodeOrigin )
+import GHC.Hs ( SrcCodeOrigin (..) )
import GHC.Tc.Utils.TcType ( TcLevel )
import GHC.Tc.Errors.Types ( TcRnMessage )
@@ -119,7 +117,7 @@ type ErrCtxtStack = [ErrCtxt]
-- | Get the original source code
get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin
-get_src_code_origin (ExpansionCodeCtxt origSrcCode : _) = Just origSrcCode
+get_src_code_origin (MkErrCtxt (ExpansionCodeCtxt origSrcCode) _ : _) = Just origSrcCode
-- we are in generated code, due to the expansion of the original syntax origSrcCode
get_src_code_origin _ = Nothing
-- we are in user code, so blame the expression in hand
@@ -127,7 +125,6 @@ get_src_code_origin _ = Nothing
data TcLclCtxt
= TcLclCtxt {
tcl_loc :: RealSrcSpan, -- Source span
- tcl_in_gen_code :: Bool,
tcl_err_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack]
tcl_tclvl :: TcLevel,
tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings,
@@ -199,33 +196,34 @@ setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt })
addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-addLclEnvErrCtxt (ExpansionCodeCtxt co) = setLclEnvSrcCodeOrigin co
-addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if (tcl_in_gen_code env)
+addLclEnvErrCtxt ec@(MkErrCtxt (ExpansionCodeCtxt _) _) = setLclEnvSrcCodeOrigin ec
+addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if lclCtxtInGeneratedCode env
then env -- no op if we are in generated code
else env { tcl_err_ctxt = ec : (tcl_err_ctxt env) })
getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin
getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt
-setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv
-setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o)
-
-setLclCtxtInGenCode :: TcLclCtxt -> TcLclCtxt
-setLclCtxtInGenCode lclCtxt = lclCtxt { tcl_in_gen_code = True }
-
-setLclCtxtInUserCode :: TcLclCtxt -> TcLclCtxt
-setLclCtxtInUserCode lclCtxt = lclCtxt { tcl_in_gen_code = False }
+setLclEnvSrcCodeOrigin :: ErrCtxt -> TcLclEnv -> TcLclEnv
+setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec)
-- See Note [ErrCtxt Stack Manipulation]
-setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt
-setLclCtxtSrcCodeOrigin o lclCtxt
- | (ExpansionCodeCtxt _ : ec) <- tcl_err_ctxt lclCtxt
- = lclCtxt { tcl_err_ctxt = ExpansionCodeCtxt o : ec }
+setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt
+setLclCtxtSrcCodeOrigin ec lclCtxt
+ | MkErrCtxt (ExpansionCodeCtxt PopErrCtxt) _ <- ec
+ = lclCtxt { tcl_err_ctxt = tail (tcl_err_ctxt lclCtxt) }
+ | MkErrCtxt (ExpansionCodeCtxt _) _ : ecs <- tcl_err_ctxt lclCtxt
+ , MkErrCtxt (ExpansionCodeCtxt _) _ <- ec
+ = lclCtxt { tcl_err_ctxt = ec : ecs }
| otherwise
- = lclCtxt { tcl_err_ctxt = ExpansionCodeCtxt o : tcl_err_ctxt lclCtxt }
+ = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt }
lclCtxtInGeneratedCode :: TcLclCtxt -> Bool
-lclCtxtInGeneratedCode = tcl_in_gen_code
+lclCtxtInGeneratedCode lclCtxt
+ | (MkErrCtxt (ExpansionCodeCtxt _) _ : _) <- tcl_err_ctxt lclCtxt
+ = True
+ | otherwise
+ = False
lclEnvInGeneratedCode :: TcLclEnv -> Bool
lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -829,7 +829,6 @@ exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e)
exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e)
exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
-exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f)
@@ -882,6 +881,7 @@ pprCtOrigin (ExpansionOrigin o)
OrigExpr (ExplicitList{}) -> text "an overloaded list"
OrigExpr (HsIf{}) -> text "an if-then-else expression"
OrigExpr e -> text "the expression" <+> (ppr e)
+ PopErrCtxt -> text "Shouldn't Happen PopErrCtxt"
pprCtOrigin (GivenSCOrigin sk d blk)
= vcat [ ctoHerald <+> pprSkolInfo sk
@@ -1113,6 +1113,7 @@ ppr_br (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression"
ppr_br (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e
ppr_br (ExpansionOrigin (OrigStmt{})) = text "a do statement"
ppr_br (ExpansionOrigin (OrigPat{})) = text "a do statement"
+ppr_br (ExpansionOrigin PopErrCtxt) = text "SHOULDN'T HAPPEN POPERRORCTXT"
ppr_br (ExpectedTySyntax o _) = ppr_br o
ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator"
ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern"
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad(
-- * Error management
getSrcCodeOrigin,
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
- inGeneratedCode, setInGeneratedCode, setInUserCode, setLclCtxtInGenCode,
+ inGeneratedCode, -- setInGeneratedCode,
wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
@@ -88,6 +88,7 @@ module GHC.Tc.Utils.Monad(
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+ addExpansionErrCtxt, addExpansionErrCtxtM,
addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
-- * Diagnostic message generation (type checker)
@@ -418,7 +419,6 @@ initTcWithGbl hsc_env gbl_env loc do_this
tcl_lcl_ctxt = TcLclCtxt {
tcl_loc = loc,
-- tcl_loc should be over-ridden very soon!
- tcl_in_gen_code = False,
tcl_err_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topLevel,
@@ -1078,10 +1078,10 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-- See Note [Error contexts in generated code]
setSrcSpan (RealSrcSpan loc _) thing_inside
- = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) thing_inside
+ = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside
setSrcSpan (UnhelpfulSpan _) thing_inside
- = updLclCtxt setLclCtxtInGenCode thing_inside
+ = thing_inside
getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin)
getSrcCodeOrigin =
@@ -1095,13 +1095,10 @@ getSrcCodeOrigin =
--
-- See Note [Error contexts in generated code]
-- See Note [Error Context Stack]
-setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a
-setInGeneratedCode sco thing_inside =
- updLclCtxt setLclCtxtInGenCode $
- updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside
-
-setInUserCode :: TcRn a -> TcRn a
-setInUserCode = updLclCtxt setLclCtxtInUserCode
+-- setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a
+-- setInGeneratedCode sco thing_inside =
+-- -- updLclCtxt setLclCtxtInGenCode $
+-- updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside
setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
@@ -1349,12 +1346,20 @@ addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a
{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a
+{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt]
+addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg))
+
-- | Add a message to the error context. This message may do tidying.
-- NB. No op in generated code
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a
{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt]
-addErrCtxtM ctxt = pushCtxt (UserCodeCtxt (False, ctxt))
+addErrCtxtM ctxt = pushCtxt (MkErrCtxt VanillaUserSrcCode ctxt)
+
+addExpansionErrCtxtM :: SrcCodeOrigin -> (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a
+{-# INLINE addExpansionErrCtxtM #-} -- Note [Inlining addErrCtxt]
+addExpansionErrCtxtM o ctxt = pushCtxt (MkErrCtxt (ExpansionCodeCtxt o) ctxt)
-- | Add a fixed landmark message to the error context. A landmark
-- message is always sure to be reported, even if there is a lot of
@@ -1368,7 +1373,7 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
-- and tidying.
addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt]
-addLandmarkErrCtxtM ctxt = pushCtxt (UserCodeCtxt (True, ctxt))
+addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt)
-- | NB. no op in generated code
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
@@ -1840,18 +1845,17 @@ mkErrCtxt env ctxts
where
go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg]
go _ _ _ [] = return []
- go dbg n env (UserCodeCtxt (is_landmark, ctxt) : ctxts)
- | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
+ go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts)
+ | n < mAX_CONTEXTS -- Too verbose || dbg
= do { (env', msg) <- liftZonkM $ ctxt env
- ; let n' = if is_landmark then n else n+1
- ; rest <- go dbg n' env' ctxts
+ ; rest <- go dbg n env' ctxts
; return (msg : rest) }
| otherwise
= go dbg n env ctxts
- go dbg n env (ExpansionCodeCtxt co : ctxts)
+ go dbg n env (MkErrCtxt _ ctxt : ctxts)
| n < mAX_CONTEXTS -- Too verbose || dbg
- = do { let msg = srcCodeOriginErrCtxMsg co
- ; rest <- go dbg (n+1) env ctxts
+ = do { (env', msg) <- liftZonkM $ ctxt env
+ ; rest <- go dbg (n+1) env' ctxts
; return (msg : rest) }
| otherwise
= go dbg n env ctxts
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/054cd63d539fd12e30ce21437a8006…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/054cd63d539fd12e30ce21437a8006…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/26507] Fix stack decoding when using profiled runtime
by Matthew Pickering (＠mpickering) 20 Oct '25
by Matthew Pickering (＠mpickering) 20 Oct '25
20 Oct '25
Matthew Pickering pushed to branch wip/26507 at Glasgow Haskell Compiler / GHC
Commits:
d450af4b by Matthew Pickering at 2025-10-20T11:42:23+01:00
Fix stack decoding when using profiled runtime
There are three fixes in this commit.
* We need to replicate the `InfoTable` and `InfoTableProf`
approach for the other stack constants (see the new Stack.ConstantsProf
file).
* Then we need to appropiately import the profiled or non-profiled
versions.
* Finally, there was an incorrect addition in `stackFrameSize`. We need
to cast after performing addition on words.
Fixes #26507
- - - - -
5 changed files:
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/tests/stack-annotation/all.T
Changes:
=====================================
libraries/ghc-internal/cbits/Stack_c.c
=====================================
@@ -9,13 +9,13 @@
#include "rts/storage/InfoTables.h"
StgWord stackFrameSize(StgStack *stack, StgWord offset) {
- StgClosure *c = (StgClosure *)stack->sp + offset;
+ StgClosure *c = (StgClosure *)(stack->sp + offset);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
return stack_frame_sizeW(c);
}
StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
- StgClosure *frame = (StgClosure *)stack->sp + offset;
+ StgClosure *frame = (StgClosure *)(stack->sp + offset);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -299,6 +299,7 @@ Library
GHC.Internal.Stack.CCS
GHC.Internal.Stack.CloneStack
GHC.Internal.Stack.Constants
+ GHC.Internal.Stack.ConstantsProf
GHC.Internal.Stack.Decode
GHC.Internal.Stack.Types
GHC.Internal.Stats
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc
=====================================
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module GHC.Internal.Stack.ConstantsProf where
+
+import GHC.Internal.Base
+import GHC.Internal.Enum
+import GHC.Internal.Num
+import GHC.Internal.Show
+import GHC.Internal.Real
+
+#define PROFILING
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+newtype WordOffset = WordOffset { offsetInWords :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+offsetStgCatchFrameHandler :: WordOffset
+offsetStgCatchFrameHandler = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+
+sizeStgCatchFrame :: Int
+sizeStgCatchFrame = bytesToWords $
+ (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchSTMFrameCode :: WordOffset
+offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+
+offsetStgCatchSTMFrameHandler :: WordOffset
+offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+
+sizeStgCatchSTMFrame :: Int
+sizeStgCatchSTMFrame = bytesToWords $
+ (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
+
+offsetStgUpdateFrameUpdatee :: WordOffset
+offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $
+ (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+
+sizeStgUpdateFrame :: Int
+sizeStgUpdateFrame = bytesToWords $
+ (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
+
+offsetStgAtomicallyFrameCode :: WordOffset
+offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $
+ (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+
+offsetStgAtomicallyFrameResult :: WordOffset
+offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $
+ (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+
+sizeStgAtomicallyFrame :: Int
+sizeStgAtomicallyFrame = bytesToWords $
+ (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningAltCode :: WordOffset
+offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
+offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameAltCode :: WordOffset
+offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $
+ (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+
+sizeStgCatchRetryFrame :: Int
+sizeStgCatchRetryFrame = bytesToWords $
+ (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
+
+offsetStgRetFunFrameSize :: WordOffset
+-- StgRetFun has no header, but only a pointer to the info table at the beginning.
+offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size)
+
+offsetStgRetFunFrameFun :: WordOffset
+offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun)
+
+offsetStgRetFunFramePayload :: WordOffset
+offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload)
+
+sizeStgRetFunFrame :: Int
+sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
+
+sizeStgAnnFrame :: Int
+sizeStgAnnFrame = bytesToWords $
+ (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader)
+
+offsetStgAnnFrameAnn :: WordOffset
+offsetStgAnnFrameAnn = byteOffsetToWordOffset $
+ (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
+
+offsetStgBCOFrameInstrs :: ByteOffset
+offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
+
+offsetStgBCOFrameLiterals :: ByteOffset
+offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
+
+offsetStgBCOFramePtrs :: ByteOffset
+offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
+
+offsetStgBCOFrameArity :: ByteOffset
+offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
+
+offsetStgBCOFrameSize :: ByteOffset
+offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
+
+offsetStgClosurePayload :: WordOffset
+offsetStgClosurePayload = byteOffsetToWordOffset $
+ (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+
+sizeStgClosure :: Int
+sizeStgClosure = bytesToWords (#size StgHeader)
+
+byteOffsetToWordOffset :: ByteOffset -> WordOffset
+byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger
+
+bytesToWords :: Int -> Int
+bytesToWords b =
+ if b `mod` bytesInWord == 0 then
+ fromIntegral $ b `div` bytesInWord
+ else
+ error "Unexpected struct alignment!"
+
+bytesInWord :: Int
+bytesInWord = (#const SIZEOF_VOID_P)
+
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -54,9 +54,19 @@ import GHC.Internal.Heap.Closures
GenStackField(..)
)
import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
-import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Heap.Closures
import GHC.Internal.Stack.Annotation
+#if defined(PROFILING)
+import GHC.Internal.Stack.Constants ()
+import GHC.Internal.Stack.ConstantsProf
+import GHC.Internal.Heap.InfoTable ()
+import GHC.Internal.Heap.InfoTableProf
+#else
+import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Heap.InfoTableProf ()
import GHC.Internal.Stack.Constants
+import GHC.Internal.Stack.ConstantsProf ()
+#endif
import GHC.Internal.Stack.CloneStack
import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
=====================================
libraries/ghc-internal/tests/stack-annotation/all.T
=====================================
@@ -1,7 +1,7 @@
# Javascript backend don't support annotation frames, yet
setTestOpts(when(js_arch(), skip))
-test('ann_frame001', [extra_files(['TestUtils.hs'])], compile_and_run, [''])
+test('ann_frame001', [extra_ways(['prof']), extra_files(['TestUtils.hs'])], compile_and_run, [''])
test('ann_frame002', [extra_files(['TestUtils.hs'])], compile_and_run, [''])
test('ann_frame003', [extra_files(['TestUtils.hs'])], compile_and_run, [''])
test('ann_frame004', [extra_files(['TestUtils.hs'])], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d450af4bf383d90778c709b2794675a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d450af4bf383d90778c709b2794675a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0