Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5841121f by Duncan Coutts at 2026-04-29T05:20:59-04:00
Make cmm 'import "package" name;' syntax use consistent label types
There is a little-used syntactic form in cmm imports:
import "package" foo;
Which means to import foo from the given package (unit id, specified as
a string). This syntax is somewhat reminiscent of GHC's package import
extension.
This syntax form is not used in the rts cmm code, nor any of the boot
libraries. It may not be used at all. Unclear.
Change the kind of CLabel this syntax generates to be consistent with
the others. The other cmm imports use ForeignLabel with
ForeignLabelInExternalPackage. For some reason this form was using
CmmLabel. Change that to also be ForeignLabel but with
ForeignLabelInPackage. This specifies a specific package, rather
than an unnamed external package.
- - - - -
674bdb80 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Change default cmm import statements to be internal
Previously a cmm statement like:
import foo;
meant to expect the symbol from a different shared library than the
current one.
Now it means to expect the symbol from the same shared library as the
current one. We'll add explicit syntax to indicate that it's a foreign
import. Most existing uses are in fact intenal (rts to rts), so few
imports will need to be annotated foreign. Examples would include cmm
code in libraries (other than the rts) that need to access RTS APIs.
In practice, this makes no difference whatsoever at the moment on any
platform other than windows (where building Haskell libs as shared libs
does not fully work yet), since the 'labelDynamic' treats all such
labels as foreign, irrespective of the foreign label source.
- - - - -
86454771 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Add cmm import syntax 'import DATA foo;' as better name for CLOSURE
The existing syntax is:
import CLOSURE foo;
The new syntax is
import DATA foo;
This means to interpret the symbol foo as refering to data (i.e. a
global constant or variable) rather than to code (a function). The
historical syntax for this uses CLOSURE, which is rather misleading.
Presumably this was done to avoid introducing new reserved words.
Be less squemish about new reserved words and add DATA and use that.
Keep the existing CLOSURE syntax as an alias for compatibility.
- - - - -
0f2a7fe5 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Add cmm 'import extern name;' syntax
Since the default for cmm imports is now for symbols within the same
shared object, we need a way to indicate we want a symbol from an
external shared object:
import extern foo; -- for a function
import extern DATA foo; -- for data
This adds a new reserved word 'extern'.
We don't expect to have to use this much. Most cmm imports are
intra-DSO.
This makes no difference currently on ELF and MachO platforms, but does
make a difference to the linking conventions on PE (Windows).
In future it's plausible we could take make distinctions on ELF or
MachO, so it's worth trying to get it right. Windows can be the guinea
pig.
- - - - -
2ea81ff9 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Add cmm syntax 'import "package" DATA foo;' for completeness
We already have:
import DATA foo; -- for data imports
import "package" foo; -- for imports from a given unitid
There's no reason not to have both at once:
import "package" DATA foo;
So add that.
- - - - -
3912ff93 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Improve the commentary for the cmm import grammar.
AFAIK, this is the only place where GHC-style Cmm syntax is documented.
- - - - -
d7e33df7 by Duncan Coutts at 2026-04-29T05:20:59-04:00
Add a changelog.d entry for the .cmm import syntax changes
- - - - -
bd6f2e08 by Rodrigo Mesquita at 2026-04-29T05:21:00-04:00
New rts Message to {set,unset} TSO flags
This commit introduces stg_MSG_SET_TSO_FLAG_info and
stg_MSG_UNSET_TSO_FLAG_info, which allows setting flags of a TSO other
than yourself.
This is especially useful/necessary to set breakpoints and toggle
breakpoints of different threads, which is needed to safely implement
features like pausing, toggling step-out, toggling step-in per thread,
etc.
Fixes #27131
-------------------------
Metric Decrease:
T3294
-------------------------
- - - - -
87a67f26 by Rodrigo Mesquita at 2026-04-29T05:21:00-04:00
test: Add test setting another TSO's flags
Introduces a test that runs on two capabilities. The main thread running
on Capability 0 sets the flags on a TSO running on Capability 1.
The TSO from Capability 1 itself checks whether its flags were set and
reports that back.
This validates that the RTS messages for setting TSO flags work, even if
it doesn't test a harsher scenario with race conditions to exercise why
the message passing is necessary for safely setting another TSO's flags.
Part of #27131
- - - - -
1dff17dd by David Eichmann at 2026-04-29T05:21:01-04:00
Hadrian: withResponseFile outputs response file when verbodity is Verbose
At the Verbose verbosity, shake will display full commandlines. With the
use of response files, the full command is hidden. That makes it hard to run
the command manually. This commit outputs the contents of the response
file so that that full command can be recreated and also hints at the
use of the --keep-response-files hadrian flag.
- - - - -
c1d2f1d0 by Duncan Coutts at 2026-04-29T05:21:01-04:00
Use response files for hadrian linking with ghc (support long command lines)
In future support for windows dynamic linking, we expect long command
lines for linking dll files with ghc. Experiments with dynamic linking the
ghc-internal library yielded a link command well over 32kb. We did not
encounter this before for static libs, since we already use ar's @file
feature (if available, which it is for the llvm toolchain).
Co-authored-by: David Eichmann
- - - - -
86285b49 by Cheng Shao at 2026-04-29T05:21:02-04:00
compiler: avoid unique OccNames for internal Names in bytecode objects
This patch improves bytecode object serialization logic by avoiding
the construction of unique `OccName`s when serializing/deserializing
internal `Name`s. Closes #27213.
-------------------------
Metric Decrease:
LinkableUsage01
-------------------------
- - - - -
8ae2a885 by Vladislav Zavialov at 2026-04-29T05:21:03-04:00
Replace GHC 9.16 references with GHC 10.0
- - - - -
30 changed files:
- + changelog.d/T27131
- + changelog.d/cmm-import-syntax-changes
- compiler/GHC/ByteCode/Binary.hs
- compiler/GHC/Cmm/Lexer.x
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Driver/Flags.hs
- docs/users_guide/debug-info.rst
- docs/users_guide/exts/explicit_namespaces.rst
- docs/users_guide/exts/linear_types.rst
- docs/users_guide/exts/modifiers.rst
- docs/users_guide/exts/qualified_strings.rst
- docs/users_guide/exts/required_type_arguments.rst
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Builder.hs
- hadrian/src/Hadrian/Utilities.hs
- hadrian/src/Settings/Builders/Ghc.hs
- rts/Interpreter.c
- rts/Messages.c
- rts/StgMiscClosures.cmm
- rts/Threads.c
- rts/Threads.h
- rts/include/rts/storage/Closures.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/rts/T27131.hs
- + testsuite/tests/rts/T27131.stdout
- + testsuite/tests/rts/T27131_c.c
- testsuite/tests/rts/all.T
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
changelog.d/T27131
=====================================
@@ -0,0 +1,8 @@
+section: rts
+synopsis: Add rts Message to set/unset TSO flags
+issues: #27131
+mrs: !15831
+description: This enables e.g. toggling breakpoints from different threads,
+ which is necessary to safely implement features like pausing, per-thread
+ step-in, and more in the haskell debugger.
+
=====================================
changelog.d/cmm-import-syntax-changes
=====================================
@@ -0,0 +1,34 @@
+section: cmm
+synopsis: Changes to Cmm hand-written syntax for symbol imports.
+issues: #27162
+mrs: !15135
+
+description: {
+ In hand-written Cmm, there is syntax to declare symbol names from outside of
+ the current .cmm file (e.g. .c or .cmm files).
+
+ The existing syntax is
+
+ > import foo; -- for a function
+ > import CLOSURE foo; -- for data
+
+ and this implicitly meant that the symbol (`foo`) could be found in an
+ external shared library, not the current one. There was no syntax to specify
+ that the symbol should be found in the current shared library, i.e. in a
+ .cmm file (or .hs file) in the current Haskell package.
+
+ The new syntax assumes local by default and allows specifying external:
+
+ > import foo; -- for a function in the current lib
+ > import DATA foo; -- for data in the current lib
+ > import extern foo; -- for a function in an external lib
+ > import extern DATA foo; -- for data in an external lib
+ > import "unitid" foo; -- for a function in the Haskell unit "unitid"
+ > import "unitid" DATA foo; -- for data in the Haskell unit "unitid"
+
+ In practice, the only platform where this can be expected to make a
+ difference is on Windows, and only when compiling each Haskell package as a
+ separate .dll dynamic library.
+}
+
+
=====================================
compiler/GHC/ByteCode/Binary.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.ByteCode.Binary (
import GHC.Prelude
import GHC.ByteCode.Types
-import GHC.Data.FastString
+import qualified GHC.Data.Word64Map.Strict as Word64Map
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.Name.Env
@@ -291,9 +291,8 @@ addBinNameWriter bh' = do
| otherwise -> do
putByte bh 1
key <- getBinNameKey env_ref nm
- -- Delimit the OccName from the deterministic counter to keep the
- -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
- put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
+ put_ bh $ occNameFS $ occName nm
+ put_ bh key
where
-- Find a deterministic key for local names. This
getBinNameKey ref name = do
@@ -304,7 +303,7 @@ addBinNameWriter bh' = do
addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
addBinNameReader nc bh' = do
- env_ref <- newIORef emptyOccEnv
+ env_ref <- newIORef Word64Map.empty
pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
t <- getByte bh
case t of
@@ -313,15 +312,16 @@ addBinNameReader nc bh' = do
pure $ BinName nm
1 -> do
occ <- mkVarOccFS <$> get bh
+ key <- get bh
-- We don't want to get a new unique from the NameCache each time we
-- see a name.
nm' <- unsafeInterleaveIO $ do
u <- takeUniqFromNameCache nc
evaluate $ mkInternalName u occ noSrcSpan
fmap BinName $ atomicModifyIORef' env_ref $ \env ->
- case lookupOccEnv env occ of
+ case Word64Map.lookup key env of
Just nm -> (env, nm)
- _ -> nm' `seq` (extendOccEnv env occ nm', nm')
+ _ -> nm' `seq` (Word64Map.insert key nm' env, nm')
_ -> panic "Binary BinName: invalid byte"
-- Note [Serializing Names in bytecode]
=====================================
compiler/GHC/Cmm/Lexer.x
=====================================
@@ -174,6 +174,8 @@ data CmmToken
| CmmT_return
| CmmT_returns
| CmmT_import
+ | CmmT_extern
+ | CmmT_DATA
| CmmT_switch
| CmmT_case
| CmmT_default
@@ -273,6 +275,8 @@ reservedWordsFM = listToUFM $
( "return", CmmT_return ),
( "returns", CmmT_returns ),
( "import", CmmT_import ),
+ ( "extern", CmmT_extern ),
+ ( "DATA", CmmT_DATA ),
( "switch", CmmT_switch ),
( "case", CmmT_case ),
( "default", CmmT_default ),
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -372,6 +372,8 @@ import qualified Data.ByteString.Char8 as BS8
'return' { L _ (CmmT_return) }
'returns' { L _ (CmmT_returns) }
'import' { L _ (CmmT_import) }
+ 'extern' { L _ (CmmT_extern) }
+ 'DATA' { L _ (CmmT_DATA) }
'switch' { L _ (CmmT_switch) }
'case' { L _ (CmmT_case) }
'default' { L _ (CmmT_default) }
@@ -643,18 +645,42 @@ importNames
importName
:: { (FastString, CLabel) }
- -- A label imported without an explicit packageId.
- -- These are taken to come from some foreign, unnamed package.
+ -- A code label imported from within the same shared library.
: NAME
- { ($1, mkForeignLabel $1 ForeignLabelInExternalPackage IsFunction) }
+ { ($1, mkForeignLabel $1 ForeignLabelInThisPackage IsFunction) }
- -- as previous 'NAME', but 'IsData'
- | 'CLOSURE' NAME
- { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsData) }
+ -- A data label imported from within the same shared library.
+ | 'DATA' NAME
+ { ($2, mkForeignLabel $2 ForeignLabelInThisPackage IsData) }
- -- A label imported with an explicit UnitId.
+ -- CLOSURE is a historical alias for DATA in this context.
+ | 'CLOSURE' NAME
+ { ($2, mkForeignLabel $2 ForeignLabelInThisPackage IsData) }
+
+ -- A code label imported from another unamed shared library. These may
+ -- come from a foreign shared library, or from the shared library for
+ -- an unnamed Haskell package. This corresponds on Windows/PE to
+ -- __declspec(dllimport) in C.
+ | 'extern' NAME
+ { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsFunction) }
+
+ -- A data label imported from another unamed shared library.
+ -- This corresponds on Windows/PE to __declspec(dllimport) in C (but
+ -- cmm doesn't know about data vs function symbols so we have to say).
+ | 'extern' 'DATA' NAME
+ { ($3, mkForeignLabel $3 ForeignLabelInExternalPackage IsData) }
+
+ -- A code label imported from the shared library for a Haskell package
+ -- with the given UnitId. Such labels behave as local when used within
+ -- the specified unit, or as extern otherwise.
| STRING NAME
- { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }
+ { ($2, mkForeignLabel $2 (ForeignLabelInPackage (UnitId (mkFastString $1))) IsFunction) }
+
+ -- A data label imported from the shared library for a Haskell package
+ -- with the given UnitId. Such labels behave as local when used within
+ -- the specified unit, or as extern otherwise.
+ | STRING 'DATA' NAME
+ { ($3, mkForeignLabel $3 (ForeignLabelInPackage (UnitId (mkFastString $1))) IsData) }
names :: { [FastString] }
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -1112,9 +1112,9 @@ data WarningFlag =
-- ^ @since 9.14, scheduled to be removed in 9.18
--
-- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig
- | Opt_WarnUnusableUnpackPragmas -- Since 9.14
- | Opt_WarnPatternNamespaceSpecifier -- Since 9.14
- | Opt_WarnUnrecognisedModifiers -- ^ @since 9.16
+ | Opt_WarnUnusableUnpackPragmas -- ^ @since 9.14
+ | Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14
+ | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
@@ -1377,7 +1377,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnTypeEqualityRequiresOperators,
Opt_WarnInconsistentFlags,
Opt_WarnTypeEqualityOutOfScope,
- Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16
+ Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 10.2 (#25911)
Opt_WarnViewPatternSignatures,
Opt_WarnUselessSpecialisations,
Opt_WarnDeprecatedPragmas,
=====================================
docs/users_guide/debug-info.rst
=====================================
@@ -478,7 +478,7 @@ to a source location. This lookup table is generated by using the ``-finfo-table
:type: dynamic
:category: debugging
- :since: 9.16
+ :since: 10.0
Disable generation of distinct info tables for all constructors.
@@ -488,7 +488,7 @@ to a source location. This lookup table is generated by using the ``-finfo-table
:type: dynamic
:category: debugging
- :since: 9.16
+ :since: 10.0
The entries in the info table map resulting from
:ghc-flag:`-fdistinct-constructor-tables` flag may significantly
=====================================
docs/users_guide/exts/explicit_namespaces.rst
=====================================
@@ -121,7 +121,7 @@ there is a need to support older GHC versions.
Wildcards in import/export lists
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-**Since:** GHC 9.16
+**Since:** GHC 10.0
Namespace-specified wildcards ``type ..`` and ``data ..`` may be used to import
all names in the corresponding namespace from a module: ::
=====================================
docs/users_guide/exts/linear_types.rst
=====================================
@@ -318,7 +318,7 @@ hidden; it is an essential part of the exposed interface.)
Interaction with Modifiers
--------------------------
-Since GHC version 9.16, Linear types use :extension:`Modifiers` syntax, and by
+Since GHC version 10.0, Linear types use :extension:`Modifiers` syntax, and by
default enable that extension. In earlier versions, linear types used a more
restricted variant of that syntax.
=====================================
docs/users_guide/exts/modifiers.rst
=====================================
@@ -6,7 +6,7 @@ Modifiers
.. extension:: Modifiers
:shortdesc: Allow experimental modifier syntax.
- :since: 9.16
+ :since: 10.0
:status: Experimental
Enable modifier syntax in various places, such as arrows (``a %m -> b``) and
@@ -138,10 +138,10 @@ and limitations.
let %1 (Just x) = ... -- (2b)
let %1 !(Just x) = ... -- (2c)
- In 9.14, (1a) and (2a) parsed as (1b) and (2b) respectively. From 9.16, (1a)
+ In 9.14, (1a) and (2a) parsed as (1b) and (2b) respectively. From 10.0, (1a)
parses as (1d), and (2a) fails to parse.
- Note that linear bindings must be strict. (1c) and (2c) parse in 9.16 the same
+ Note that linear bindings must be strict. (1c) and (2c) parse in 10.0 the same
as in 9.14. But with ``-XStrict`` enabled, (1a) and (2a) would previously have
been accepted, and are now rejected, even with
``-XLinearTypes -XNoModifiers``.
=====================================
docs/users_guide/exts/qualified_strings.rst
=====================================
@@ -6,7 +6,7 @@ Qualified string literals
.. extension:: QualifiedStrings
:shortdesc: Enable qualified string literals.
- :since: 9.16.1
+ :since: 10.0.1
Enable qualified string literals.
=====================================
docs/users_guide/exts/required_type_arguments.rst
=====================================
@@ -303,7 +303,7 @@ A few limitations apply:
* In term syntax, in positions where ``*`` is a direct argument to ``->``, e.g.
in ``f (* -> * -> *)`` and ``f (* -> Constraint)``, the ``*``\s stand for
``Type``, provided the :extension:`StarIsType` extension is enabled.
- This is supported from GHC 9.16 onwards; earlier versions will produce
+ This is supported from GHC 10.0 onwards; earlier versions will produce
a parse error.
What to do instead: use ``Type`` from the ``Data.Kind`` module.
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2711,7 +2711,7 @@ of ``-W(no-)*``.
:type: dynamic
:reverse: -Wno-unrecognised-modifiers
- :since: 9.16
+ :since: 10.0
:default: on
=====================================
docs/users_guide/using.rst
=====================================
@@ -1618,7 +1618,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1639,7 +1639,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1684,7 +1684,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1823,7 +1823,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
(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 GFNI instructions.
=====================================
hadrian/src/Builder.hs
=====================================
@@ -345,11 +345,7 @@ instance H.Builder Builder where
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
- Ghc FindHsDependencies _ -> do
- -- Use a response file for ghc -M invocations, to
- -- avoid issues with command line size limit on
- -- Windows (#26637)
- runGhcWithResponse path buildArgs buildInputs
+ Ghc _ _ -> runGhcWithResponse path buildArgs buildInputs buildOptions
HsCpp -> captureStdout
@@ -393,14 +389,19 @@ runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
-runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
-runGhcWithResponse ghcPath flagArgs fileInputs = withResponseFile $ \tmp -> do
- writeFile' tmp $ escapeArgs fileInputs
- -- We can't put the flags in a response file, because some flags
- -- require empty arguments (such as the -dep-suffix flag), but
- -- that isn't supported yet due to #26560.
- cmd [ghcPath] flagArgs ('@' : tmp)
-
+-- | Use a response file for ghc invocations to avoid issues with command line
+-- size limit on Windows (#26637).
+runGhcWithResponse :: FilePath -- ^ Path to ghc
+ -> [String] -- ^ Arguments passed on the command line
+ -> [FilePath] -- ^ Input file paths (passed via response file)
+ -> [CmdOption]
+ -> Action ()
+runGhcWithResponse ghcPath buildArgs buildInputs buildOptions = withResponseFile $ \tmp -> do
+ -- We can't put the buildArgs in a response file, because some flags require
+ -- empty arguments (such as the -dep-suffix flag), but that isn't supported
+ -- yet due to #26560.
+ writeFile' tmp (escapeArgs buildInputs)
+ cmd [ghcPath] buildArgs ('@' : tmp) buildOptions
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
=====================================
hadrian/src/Hadrian/Builder.hs
=====================================
@@ -29,7 +29,9 @@ import Hadrian.Utilities
-- | This data structure captures all information relevant to invoking a builder.
data BuildInfo = BuildInfo {
- -- | Command line arguments.
+ -- | Command line arguments. Some builders (e.g. Ar, Ghc, Haddock) omit
+ -- buildInputs from buildArgs so that buildInputs can be passed separately
+ -- using a response file.
buildArgs :: [String],
-- | Input files.
buildInputs :: [FilePath],
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -334,13 +334,23 @@ keepResponseFiles = do
withResponseFile :: (FilePath -> Action a) -> Action a
withResponseFile action = do
keep <- keepResponseFiles
+ let putVerboseResponseFile tmp = do
+ verbosity <- getVerbosity
+ when (verbosity >= Verbose) $ do
+ tmpContent <- liftIO (readFile tmp)
+ putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
if keep
then do
(tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
liftIO $ hClose h
putInfo $ "Keeping response file: " ++ tmp
- action tmp
- else withTempFile action
+ result <- action tmp
+ putVerboseResponseFile tmp
+ return result
+ else withTempFile $ \tmp -> do
+ result <- action tmp
+ putVerboseResponseFile tmp
+ return result
-- | Link a file tracking the link target. Create the target directory if
-- missing.
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -62,7 +62,6 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
[ arg "-fwrite-ide-info"
, arg "-hiedir", arg hie_path
]
- , getInputs
, arg "-o", arg =<< getOutput ]
compileC :: Args
@@ -78,7 +77,6 @@ compileC = builder (Ghc CompileCWithGhc) ? do
, mconcat (map (map ("-optc" ++) <$>) ccArgs)
, defaultGhcWarningsArgs
, arg "-c"
- , getInputs
, arg "-o"
, arg =<< getOutput ]
@@ -95,7 +93,6 @@ compileCxx = builder (Ghc CompileCppWithGhc) ? do
, mconcat (map (map ("-optcxx" ++) <$>) ccArgs)
, defaultGhcWarningsArgs
, arg "-c"
- , getInputs
, arg "-o"
, arg =<< getOutput ]
=====================================
rts/Interpreter.c
=====================================
@@ -416,12 +416,22 @@ void rts_disableStopNextBreakpointAll(void)
void rts_enableStopNextBreakpoint(StgTSO* tso)
{
- tso->flags |= TSO_STOP_NEXT_BREAKPOINT;
+#if defined(THREADED_RTS)
+ Capability* cap = rts_unsafeGetMyCapability();
+ setThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT);
+#else
+ tso->flags |= TSO_STOP_NEXT_BREAKPOINT;
+#endif
}
void rts_disableStopNextBreakpoint(StgTSO* tso)
{
- tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT;
+#if defined(THREADED_RTS)
+ Capability* cap = rts_unsafeGetMyCapability();
+ unsetThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT);
+#else
+ tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT;
+#endif
}
/* ---------------------------------------------------------------------------
@@ -430,12 +440,22 @@ void rts_disableStopNextBreakpoint(StgTSO* tso)
void rts_enableStopAfterReturn(StgTSO* tso)
{
+#if defined(THREADED_RTS)
+ Capability* cap = rts_unsafeGetMyCapability();
+ setThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN);
+#else
tso->flags |= TSO_STOP_AFTER_RETURN;
+#endif
}
void rts_disableStopAfterReturn(StgTSO* tso)
{
+#if defined(THREADED_RTS)
+ Capability* cap = rts_unsafeGetMyCapability();
+ unsetThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN);
+#else
tso->flags &= ~TSO_STOP_AFTER_RETURN;
+#endif
}
/*
=====================================
rts/Messages.c
=====================================
@@ -35,7 +35,9 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
i != &stg_MSG_TRY_WAKEUP_info &&
i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked
i != &stg_WHITEHOLE_info &&
- i != &stg_MSG_CLONE_STACK_info) {
+ i != &stg_MSG_CLONE_STACK_info &&
+ i != &stg_MSG_SET_TSO_FLAG_info &&
+ i != &stg_MSG_UNSET_TSO_FLAG_info) {
barf("sendMessage: %p", i);
}
}
@@ -137,6 +139,16 @@ loop:
MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
handleCloneStackMessage(cap, cloneStackMessage);
}
+ else if(i == &stg_MSG_SET_TSO_FLAG_info){
+ MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m;
+ u->tso->flags |= u->flag;
+ return;
+ }
+ else if(i == &stg_MSG_UNSET_TSO_FLAG_info){
+ MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m;
+ u->tso->flags &= ~u->flag;
+ return;
+ }
else
{
barf("executeMessage: %p", i);
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -855,6 +855,12 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL")
INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK")
{ ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; }
+INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,2,1,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG")
+{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; }
+
+INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,2,1,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG")
+{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; }
+
/* ----------------------------------------------------------------------------
END_TSO_QUEUE
=====================================
rts/Threads.c
=====================================
@@ -376,6 +376,38 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to)
tryWakeupThread(from, tso);
}
+/* ----------------------------------------------------------------------------
+ {set,unset}ThreadFlag
+
+ sets or unsets a flag in a given TSO
+ ------------------------------------------------------------------------- */
+
+#if defined(THREADED_RTS)
+static void
+updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info);
+
+void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag)
+{
+ updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info);
+}
+
+void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag)
+{
+ updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info);
+}
+
+static void
+updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info)
+{
+ MessageUpdTSOFlag *msg;
+ msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag));
+ msg->tso = tso;
+ msg->flag = flag;
+ SET_HDR_RELEASE(msg, info, CCS_SYSTEM);
+ sendMessage(from, tso->cap, (Message*)msg);
+}
+#endif
+
/* ----------------------------------------------------------------------------
awakenBlockedQueue
=====================================
rts/Threads.h
=====================================
@@ -19,6 +19,11 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso);
void tryWakeupThread (Capability *cap, StgTSO *tso);
void migrateThread (Capability *from, StgTSO *tso, Capability *to);
+#if defined(THREADED_RTS)
+void setThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag);
+void unsetThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag);
+#endif
+
// Wakes up a thread on a Capability (probably a different Capability
// from the one held by the current Task).
//
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -620,6 +620,12 @@ typedef struct MessageCloneStack_ {
StgTSO *tso;
} MessageCloneStack;
+typedef struct MessageUpdTSOFlag_ {
+ StgHeader header;
+ Message *link;
+ StgTSO *tso;
+ StgWord flag;
+} MessageUpdTSOFlag;
/* ----------------------------------------------------------------------------
Compact Regions
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -152,6 +152,8 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP);
RTS_ENTRY(stg_MSG_THROWTO);
RTS_ENTRY(stg_MSG_BLACKHOLE);
RTS_ENTRY(stg_MSG_CLONE_STACK);
+RTS_ENTRY(stg_MSG_SET_TSO_FLAG);
+RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG);
RTS_ENTRY(stg_MSG_NULL);
RTS_ENTRY(stg_MVAR_TSO_QUEUE);
RTS_ENTRY(stg_catch);
=====================================
testsuite/tests/rts/T27131.hs
=====================================
@@ -0,0 +1,81 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Monad
+import Foreign.C.Types
+import GHC.Conc.Sync (ThreadId(..), forkOn, myThreadId, setNumCapabilities)
+import GHC.Exts (ThreadId#)
+
+foreign import ccall unsafe "rts_enableStopNextBreakpoint"
+ rts_enableStopNextBreakpoint :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableStopNextBreakpoint"
+ rts_disableStopNextBreakpoint :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_enableStopAfterReturn"
+ rts_enableStopAfterReturn :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableStopAfterReturn"
+ rts_disableStopAfterReturn :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "has_local_stop_next_breakpoint"
+ c_hasLocalStopNextBreakpoint :: IO CInt
+
+foreign import ccall unsafe "has_local_stop_after_return"
+ c_hasLocalStopAfterReturn :: IO CInt
+
+main :: IO ()
+main = do
+ setNumCapabilities 2
+ checkFlag
+ "TSO_STOP_NEXT_BREAKPOINT"
+ rts_enableStopNextBreakpoint
+ rts_disableStopNextBreakpoint
+ c_hasLocalStopNextBreakpoint
+ checkFlag
+ "TSO_STOP_AFTER_RETURN"
+ rts_enableStopAfterReturn
+ rts_disableStopAfterReturn
+ c_hasLocalStopAfterReturn
+
+checkFlag
+ :: String
+ -> (ThreadId# -> IO ())
+ -> (ThreadId# -> IO ())
+ -> IO CInt
+ -> IO ()
+checkFlag label enable disable isMyThreadFlagSet = do
+ -- Print the main thread's capability (should be 0)
+ print =<< threadCapability =<< myThreadId
+
+ -- Target thread will write its own flag value here
+ targetCheckVar <- newEmptyMVar
+
+ -- Run the new TSO runs on capability 1
+ ThreadId tid# <- forkOn 1 $ do
+ replicateM_ 2 $ do
+ replyVar <- takeMVar targetCheckVar
+ isSet <- (/= 0) <$> isMyThreadFlagSet
+ putMVar replyVar isSet
+
+ -- Enable the other TSO's flag
+ enable tid#
+ -- It will check whether it is set and reply here
+ renderCheck label "set" =<< checkTarget targetCheckVar
+
+ -- Ditto.
+ disable tid#
+ renderCheck label "unset" . not =<< checkTarget targetCheckVar
+
+checkTarget :: MVar (MVar Bool) -> IO Bool
+checkTarget targetCheckVar = do
+ replyVar <- newEmptyMVar
+ putMVar targetCheckVar replyVar
+ takeMVar replyVar
+
+renderCheck :: String -> String -> Bool -> IO ()
+renderCheck label state ok = putStrLn $
+ label ++ " " ++ state ++ ": " ++ if ok then "ok" else "failed"
=====================================
testsuite/tests/rts/T27131.stdout
=====================================
@@ -0,0 +1,6 @@
+(0,False)
+TSO_STOP_NEXT_BREAKPOINT set: ok
+TSO_STOP_NEXT_BREAKPOINT unset: ok
+(0,False)
+TSO_STOP_AFTER_RETURN set: ok
+TSO_STOP_AFTER_RETURN unset: ok
=====================================
testsuite/tests/rts/T27131_c.c
=====================================
@@ -0,0 +1,15 @@
+#include "Rts.h"
+
+int has_local_stop_next_breakpoint(void)
+{
+ CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability();
+ StgTSO *tso = cap->r.rCurrentTSO;
+ return (tso->flags & TSO_STOP_NEXT_BREAKPOINT) != 0;
+}
+
+int has_local_stop_after_return(void)
+{
+ CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability();
+ StgTSO *tso = cap->r.rCurrentTSO;
+ return (tso->flags & TSO_STOP_AFTER_RETURN) != 0;
+}
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -623,6 +623,12 @@ test('T20201b', [js_skip, exit_code(1)], compile_and_run, ['-with-rtsopts -A64z'
test('T22012', [js_skip, extra_ways(['ghci'])], compile_and_run, ['T22012_c.c'])
+test('T27131',
+ [ only_ways(['threaded1', 'threaded2'])
+ , req_ghc_with_threaded_rts
+ ],
+ compile_and_run, ['T27131_c.c'])
+
# Skip for JS platform as the JS RTS is always single threaded
test('T22795a', [only_ways(['normal']), js_skip, req_ghc_with_threaded_rts], compile_and_run, ['-threaded'])
test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-threaded'])
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -720,7 +720,7 @@ test('T17940', normal, compile_fail, [''])
test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
test('T24064', normal, compile_fail, [''])
test('T24090a', normal, compile_fail, [''])
-test('T24090b', normal, compile, ['']) # scheduled to become an actual error in GHC 9.16
+test('T24090b', normal, compile, ['']) # scheduled to become an actual error in GHC 10.2 (#25911)
test('T24298', normal, compile_fail, [''])
test('T24279', normal, compile, ['']) # Now accepted (Nov 2025)
test('T24318', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/83413382382026efed1afcdd0b899d5...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/83413382382026efed1afcdd0b899d5...
You're receiving this email because of your account on gitlab.haskell.org.
