03 Jul '26
Simon Jakobi pushed new branch wip/sjakobi/cpr-docs at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/cpr-docs
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T27466] Honour -dsuppress-coercions in GHC.Core.TyCo.pprCo
by Simon Peyton Jones (＠simonpj) 03 Jul '26
by Simon Peyton Jones (＠simonpj) 03 Jul '26
03 Jul '26
Simon Peyton Jones pushed to branch wip/T27466 at Glasgow Haskell Compiler / GHC
Commits:
397b8c44 by Simon Peyton Jones at 2026-07-03T03:31:35+01:00
Honour -dsuppress-coercions in GHC.Core.TyCo.pprCo
Fixes #27467
- - - - -
1 changed file:
- compiler/GHC/Core/Ppr.hs
Changes:
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -292,14 +292,14 @@ noParens :: SDoc -> SDoc
noParens pp = pp
pprOptCo :: Coercion -> SDoc
--- Print a coercion with its type
+-- Print a coercion with its type (unless suppressed by -dsuppress-coercion-types)
-- Honour -dsuppress-coercions
-- Placed here because it needs GHC.Core.Coercion.coercionType
-pprOptCo co = sep [pprCo co, dcolon <+> co_type]
- where
- co_type = sdocOption sdocSuppressCoercionTypes $ \case
- True -> ellipsis
- False -> ppr (coercionType co)
+pprOptCo co = sdocOption sdocSuppressCoercionTypes $ \case
+ True -> pprParendCo co
+ False -> parens (sep [pprCo co, dcolon <+> pp_co_type])
+ where
+ pp_co_type = ppr (coercionType co)
ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ add_par id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/397b8c44db6f1e59dfb54e8cf6c2dde…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/397b8c44db6f1e59dfb54e8cf6c2dde…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Test driver: normalise line numbers into libraries
by Marge Bot (＠marge-bot) 03 Jul '26
by Marge Bot (＠marge-bot) 03 Jul '26
03 Jul '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00
Test driver: normalise line numbers into libraries
When comparing the stdout of tests that print out callstacks, we can't
rely on the stability of exact line:column spans pointing into libraries
(e.g. ghc-internal), as any change (such as adding a comment) can change
them.
This commit addresses this by normalising away line:column in callstacks,
but only when those point into internal libraries. We don't do this in
general, as the exact span might be important to the test (e.g. for a
span within the test module itself).
Fixes #27387
- - - - -
81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00
EPA: Remove LocatedLW from MatchGroup
This is the last usage of LocatedLW / SrcSpanAnnLW
- - - - -
e83bfacf by Recursion Ninja at 2026-07-02T22:11:03-04:00
Decoupling 'L.H.S' from 'GHC.Hs.Doc'
* Migrated 'GHC.Hs.Doc' and 'GHC.Hs.DocString' AST defintions from 'GHC.*' namespace,
to new 'Language.Haskell.Syntax.Doc' module in the 'L.H.S' "namespace."
* Updated 'HsDocString to be TTG-parameterised as 'HsDocString pass'.
* Added 'GHC.Hs.Extension.Pass': splits 'GhcPass'/'Pass' and all 'HsDocString'
TTG instances out of 'GHC.Hs.Extension', which re-exports it unchanged
(this is backwards compatible and prevents the introduction of a boot file).
* Deleted 'GHC.Hs.Doc.hs-boot'; removed all 'L.H.S.*' imports of 'GHC.Hs.Doc'.
* Updated 'GHC.Hs.DocString' to be TTG pass-parameterised throughout; moved
'mkHsDocStringChunk'/'unpackHDSC' here (require 'GHC.Utils.Encoding').
* Split 'GHC.Rename.Doc.rnHsDoc' from 'rnHsDocIdentifiersOnly'.
* Updated parser, renamer, typechecker, HIE, and exact-print for new types.
* Added 'HsDocString' TTG instances for 'DocNameI' to 'Haddock.Types'.
* Killed the last module loop between GHC.* and LHS.*.
- Only edges from LHS.* to GHC.Data.FastString now!
Resolves #26971
- - - - -
bfbc9047 by mangoiv at 2026-07-02T22:11:04-04:00
ci: retry fetching test metrics
Retry fetching test metrics to make the CI not fail if the services is
temporarily unavailable
- - - - -
adc9fa86 by sheaf at 2026-07-02T22:11:05-04:00
Remove outdated comment in GHC.Data.ShortText
There was a long comment in GHC.Data.ShortText about a workaround that
was necessary when bootstrapping with GHC 9.2 and below. The actual
logic has since been dropped, but the comment remained. This commit
removes the vestigial comment.
- - - - -
78 changed files:
- .gitlab/test-metrics.sh
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Doc.hs
- − compiler/GHC/Hs/Doc.hs-boot
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- + compiler/GHC/Hs/Extension/Pass.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Doc.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Errors/Hole/FitTypes.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- + compiler/Language/Haskell/Syntax/Doc.hs
- compiler/Language/Haskell/Syntax/Expr.hs-boot
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Type.hs
- − compiler/Language/Haskell/Syntax/Type.hs-boot
- compiler/ghc.cabal.in
- libraries/ghc-boot/GHC/Data/ShortText.hs
- testsuite/driver/testlib.py
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T15279.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/showIface/DocsInHiFile1.stdout
- testsuite/tests/showIface/HaddockSpanIssueT24378.stdout
- testsuite/tests/showIface/MagicHashInHaddocks.stdout
- testsuite/tests/showIface/NoExportList.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c602ab21dc730858eeb4b2ca6224b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c602ab21dc730858eeb4b2ca6224b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
03 Jul '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00
EPA: Remove LocatedLW from MatchGroup
This is the last usage of LocatedLW / SrcSpanAnnLW
- - - - -
32 changed files:
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/ThToHs.hs
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T15279.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81ee62e0b6bd8eda137d197ced3716b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81ee62e0b6bd8eda137d197ced3716b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Test driver: normalise line numbers into libraries
by Marge Bot (＠marge-bot) 03 Jul '26
by Marge Bot (＠marge-bot) 03 Jul '26
03 Jul '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00
Test driver: normalise line numbers into libraries
When comparing the stdout of tests that print out callstacks, we can't
rely on the stability of exact line:column spans pointing into libraries
(e.g. ghc-internal), as any change (such as adding a comment) can change
them.
This commit addresses this by normalising away line:column in callstacks,
but only when those point into internal libraries. We don't do this in
general, as the exact span might be important to the test (e.g. for a
span within the test module itself).
Fixes #27387
- - - - -
1 changed file:
- testsuite/driver/testlib.py
Changes:
=====================================
testsuite/driver/testlib.py
=====================================
@@ -2944,6 +2944,12 @@ def normalise_whitespace(s: str) -> str:
callSite_re = re.compile(r', called at (.+):[\d]+:[\d]+ in [<>\w\-\.]+:')
+# A line:column location pointing inside 'libraries' (e.g. ghc-internal).
+inLibrariesLoc_re = re.compile(
+ r'(libraries[\\/]\S+?)'
+ r':(?:\d+:\d+(?:-\d+)?|\(\d+,\d+\)-\(\d+,\d+\))' # line:col span
+)
+
def normalise_callstacks(s: str) -> str:
opts = getTestOpts()
def repl(matches):
@@ -2952,6 +2958,12 @@ def normalise_callstacks(s: str) -> str:
return ', called at {0}:<line>:<column> in <package-id>:'.format(location)
# Ignore line number differences in call stacks (#10834).
s = re.sub(callSite_re, repl, s)
+ # Ignore differences in line numbers pointing into internal libraries,
+ # as those line numbers are not stable (e.g. adding a comment somewhere
+ # in ghc-internal) (#27387).
+ s = re.sub(inLibrariesLoc_re,
+ lambda m: '{0}:<line>:<column>'.format(normalise_slashes_(m.group(1))),
+ s)
# Ignore the change in how we identify implicit call-stacks
s = s.replace('from ImplicitParams', 'from HasCallStack')
if not opts.keep_prof_callstacks:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6d53c1681d4afe7f6c637c3a34798f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6d53c1681d4afe7f6c637c3a34798f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 5 commits: Adjust releaseCapability_ precondition to allow cap->running_task == NULL
by Marge Bot (＠marge-bot) 03 Jul '26
by Marge Bot (＠marge-bot) 03 Jul '26
03 Jul '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6e381626 by Duncan Coutts at 2026-07-01T22:29:55+01:00
Adjust releaseCapability_ precondition to allow cap->running_task == NULL
There are two use cases for releaseCapability_:
1. The current Task (cap->running_task) releases the Capability.
The Capability is marked free, and if there is any work to do,
an appropriate Task is woken up.
2. There is no current task (cap->task == NULL), and thus the
Capability is idle, and we want to wake up an idle Task to animate
the Capability. This case uses always_wakeup.
Currently, the precondition for releaseCapability_ is
cap->running_task != NULL
and so the 2nd use cases have to set cap->running_task (which is then
immediately overwritten) just to satisfy the precondition. See the
use cases in sendMessage and prodCapability.
So we can relax the precondition to be:
cap->running_task != NULL || always_wakeup
so that in the always_wakeup case, we say it is ok for the
cap->running_task to be NULL.
This lets us simplify sendMessage and prodCapability. In particular it
will allow prodCapability to not need a Task parameter.
The ulterior motive for all this is that I want to be able to call
prodCapability from an OS thread that is not itself a Task, in persuit
of issue #27086: disentangle I/O managers from wakeUpRts. The most
straightforward way to wake the RTS is using prodCapability, but the
context in which we will need to do that are threads that are not Tasks.
- - - - -
89404ebc by Duncan Coutts at 2026-07-01T22:29:55+01:00
prodCapability no longer needs to take a Task param
Now that releaseCapability_ can accept cap->running_task == NULL then it
is no longer necessary for prodCapability to require a Task.
- - - - -
4e60c5f6 by Duncan Coutts at 2026-07-01T22:29:56+01:00
Define prodOneCapability
There was an existing declaration for this in the header file, but no
definition.
Similarly, there is a declaration for prodAllCapabilities but no
definition, and we don't need it, so remove the declaration.
- - - - -
2527026f by Duncan Coutts at 2026-07-01T22:29:56+01:00
Add a wakeUpRtsViaTicker feature to the posix ticker
It proxies a call to wakeUpRts, but crucially, this can be called from
a signal handler context. It will be used for ctl-c handling.
- - - - -
aa5a03a5 by Duncan Coutts at 2026-07-01T22:29:56+01:00
Change how wakeUpRts works
Previously it would call wakeupIOManager to get a capability to wake up
and run. This works but it entangles the I/O managers with unrelated
features: ctl-c handling and idle gc (the two features that use wakeUpRts).
The reason it used wakeupIOManager is that this action is safe to use
from a posix signal handler, since it just posts bytes to a pipe.
Otherwise the more direct approach (used e.g. by sendMessage when the
target capability is idle) is to use releaseCapability. But that uses
condition variables and mutexes, which are not safe to use from within a
signal handler.
So instead of entangling the (multiple) I/O managers with this, we make
wakeUpRts use the direct approach (using prodOneCapability). On win32
the ctl-c console handler can call wakeUpRts directly, since it is
called in a proper thread. On posix, to deal with the signal handler
problem, we make the signal handler ask the ticker thread to proxy the
call to wakeUpRts, since the ticker thread is also a proper thread.
This will allow the I/O managers to no longer be concerned with this.
This is good because there are many I/O managers (and they're
complicated), but there is (on posix) only one ticker implementation. So
this is an overall reduction in coupling and complexity.
Fixes issue #27086
- - - - -
7 changed files:
- rts/Capability.c
- rts/Capability.h
- rts/Messages.c
- rts/Schedule.c
- rts/Ticker.h
- rts/posix/Ticker.c
- rts/sm/GC.c
Changes:
=====================================
rts/Capability.c
=====================================
@@ -525,13 +525,20 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task)
/* ----------------------------------------------------------------------------
* releaseCapability
*
- * The current Task (cap->task) releases the Capability. The Capability is
- * marked free, and if there is any work to do, an appropriate Task is woken up.
+ * This serves two purposes:
+ *
+ * 1. The current Task (cap->running_task) releases the Capability.
+ * The Capability is marked free, and if there is any work to do, an
+ * appropriate Task is woken up.
+ *
+ * 2. There is no current task (cap->task == NULL), and thus the Capability
+ * is idle, and we want to wake up an idle Task to animate the Capability.
+ * In this case set always_wakeup. See also prodCapability.
*
* The caller must hold cap->lock and will still hold it after
* releaseCapability returns.
*
- * N.B. May need to take all_tasks_mutex.
+ * N.B. May need to take all_tasks_mutex, if it needs to start a new task.
*
* ------------------------------------------------------------------------- */
@@ -540,12 +547,18 @@ void
releaseCapability_ (Capability* cap,
bool always_wakeup)
{
- Task *task;
-
- task = cap->running_task;
-
- ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task);
- ASSERT_RETURNING_TASKS(cap,task);
+ {
+ Task *task = cap->running_task;
+
+ ASSERT(task || always_wakeup);
+ // To cover purpose 2 above, we allow the cap->running_task to be
+ // NULL, to handle cases where a thread (that is not itself a Task)
+ // needs to wake up an idle task for the capability.
+ if (task) {
+ ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task);
+ ASSERT_RETURNING_TASKS(cap,task);
+ }
+ }
ASSERT_LOCK_HELD(&cap->lock);
RELAXED_STORE(&cap->running_task, NULL);
@@ -581,8 +594,8 @@ releaseCapability_ (Capability* cap,
// assertion is false: in schedule() we force a yield after
// ThreadBlocked, but the thread may be back on the run queue
// by now.
- task = peekRunQueue(cap)->bound->task;
- giveCapabilityToTask(cap, task);
+ Task *btask = peekRunQueue(cap)->bound->task;
+ giveCapabilityToTask(cap, btask);
return;
}
@@ -1087,16 +1100,25 @@ yieldCapability
#if defined(THREADED_RTS)
void
-prodCapability (Capability *cap, Task *task)
+prodCapability (Capability *cap)
{
ACQUIRE_LOCK(&cap->lock);
if (!cap->running_task) {
- cap->running_task = task;
releaseCapability_(cap,true);
}
RELEASE_LOCK(&cap->lock);
}
+/* Ensure at least one capability is not idle. Used to wake up the RTS
+ * in cases where we anticipate that all capabilities may be idle. In
+ * particular it is used for the ctl-c handler, and after the idle GC
+ * timeout to initiate idle GC. */
+void
+prodOneCapability (void)
+{
+ prodCapability(getCapability(0));
+}
+
#endif /* THREADED_RTS */
/* ----------------------------------------------------------------------------
=====================================
rts/Capability.h
=====================================
@@ -348,11 +348,7 @@ bool yieldCapability (Capability** pCap, Task *task, bool gcAllowed);
// need to service some global event.
//
void prodOneCapability (void);
-void prodCapability (Capability *cap, Task *task);
-
-// Similar to prodOneCapability(), but prods all of them.
-//
-void prodAllCapabilities (void);
+void prodCapability (Capability *cap);
// Attempt to gain control of a Capability if it is free.
//
=====================================
rts/Messages.c
=====================================
@@ -49,9 +49,11 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
recordClosureMutated(from_cap,(StgClosure*)msg);
if (to_cap->running_task == NULL) {
- to_cap->running_task = myTask();
- // precond for releaseCapability_()
- releaseCapability_(to_cap,false);
+ /* Precond for releaseCapability_ is: running_task || always_wakeup.
+ * We have running_task == NULL, hence we must use always_wakeup. This
+ * is ok since the inbox is now non-empty, so we wake a task anyway.
+ */
+ releaseCapability_(to_cap, true /*always_wakeup*/);
} else {
interruptCapability(to_cap);
}
=====================================
rts/Schedule.c
=====================================
@@ -2885,8 +2885,8 @@ performBlockingMajorGC(void)
}
/* ---------------------------------------------------------------------------
- Interrupt execution.
- Might be called inside a signal handler so it mustn't do anything fancy.
+ Interrupt execution in response to ctl-c.
+ On posix, ctl-c is a signal, while on Win32 it is a console event.
------------------------------------------------------------------------ */
void
@@ -2896,17 +2896,37 @@ interruptStgRts(void)
setSchedState(SCHED_INTERRUPTING);
interruptAllCapabilities();
#if defined(THREADED_RTS)
+ /* It may be that all capabilities are idle. If so, we must wake one up. */
+#if defined(mingw32_HOST_OS)
+ /* On win32, console handlers are invoked in a proper thread, so we can
+ * directly call wakeUpRts. Although it is an OS thread, it is not one
+ * we created or control necessarily, so it may have no associated Task.
+ */
wakeUpRts();
+#else
+ /* On posix on the other hand, signal handlers are very limited in what
+ * they can do. We cannot directly call wakeUpRts below because it is not
+ * signal safe (it uses cond vars to wake up a task). So instead we proxy
+ * it: we interrupt the ticker thread and ask the ticker thread to call
+ * wakeUpRts below. The ticker thread is a proper thread and so can call
+ * wakeUpRts. We can interrupt the ticker thread from signal handler
+ * context safely because it only involves writing to a pipe/eventfd.
+ */
+ wakeUpRtsViaTicker();
+#endif
#endif
}
/* -----------------------------------------------------------------------------
Wake up the RTS
- This function causes at least one OS thread to wake up and run the
- scheduler loop. It is invoked when the RTS might be deadlocked, or
- an external event has arrived that may need servicing (eg. a
- keyboard interrupt).
+ This function causes at least one task to wake up and run the scheduler
+ loop on at least one capability.
+
+ It is invoked:
+ 1. as part of the idle GC scheme: when the RTS has been idle for long enough
+ and it is time to go back to the scheduler which will invoke idle GC; or
+ 2. when a ctl-c occurs (posix sigint signal or win32 console event)
In the single-threaded RTS we don't do anything here; we only have
one thread anyway, and the event that caused us to want to wake up
@@ -2916,10 +2936,11 @@ interruptStgRts(void)
#if defined(THREADED_RTS)
void wakeUpRts(void)
{
- // This forces the IO Manager thread to wakeup, which will
- // in turn ensure that some OS thread wakes up and runs the
- // scheduler loop, which will cause a GC and deadlock check.
- wakeupIOManager();
+ /* Our current thread may not have a Task, in particular it will not when
+ * called from interruptStgRts or via wakeUpRtsViaTicker. This is ok,
+ * prodOneCapability does not require one.
+ */
+ prodOneCapability();
}
#endif
=====================================
rts/Ticker.h
=====================================
@@ -52,4 +52,8 @@ void exitTicker(void);
void pauseTicker(void);
void unpauseTicker(void);
+#if defined(THREADED_RTS)
+void wakeUpRtsViaTicker(void);
+#endif
+
#include "EndPrivate.h"
=====================================
rts/posix/Ticker.c
=====================================
@@ -127,6 +127,13 @@ static Time ticker_interval = DEFAULT_TICK_INTERVAL;
// acknowledgement.
static bool pause_request;
+#if defined(THREADED_RTS)
+// Atomic variable used by the ctl-c handler (posix signal handler) to
+// communicate that the ticker thread should wake up the rts. This
+// communication is one-way, with no acknowledgement.
+static bool interrupt_request;
+#endif
+
// Atomic variable used by other threads to communicate that they want the
// ticker thread to exit.
static bool exit_request;
@@ -177,6 +184,13 @@ static void *ticker_thread_func(void *_handle_tick)
paused = ACQUIRE_LOAD_ALWAYS(&pause_request);
exit = RELAXED_LOAD_ALWAYS(&exit_request);
+
+#if defined(THREADED_RTS)
+ if (RELAXED_LOAD_ALWAYS(&interrupt_request)) {
+ RELEASE_STORE_ALWAYS(&interrupt_request, false);
+ wakeUpRts();
+ }
+#endif
} else if (errno != EINTR) {
// While the RTS attempts to mask signals, some foreign libraries
// that rely on signal delivery may unmask them. Consequently we
@@ -262,6 +276,14 @@ void pauseTicker(void)
sendFdWakeup(notifyfd_w);
}
+#if defined(THREADED_RTS)
+void wakeUpRtsViaTicker(void)
+{
+ RELAXED_STORE_ALWAYS(&interrupt_request, true);
+ sendFdWakeup(notifyfd_w);
+}
+#endif
+
/* Synchronous. Not idempotent.
* The ticker is guaranteed stopped after this.
*/
=====================================
rts/sm/GC.c
=====================================
@@ -1522,7 +1522,7 @@ waitForGcThreads (Capability *cap, bool idle_cap[])
for(i = 0; i < getNumCapabilities(); ++i) {
if (i == me || idle_cap[i]) { continue; }
if (SEQ_CST_LOAD(&gc_threads[i]->wakeup) != GC_THREAD_STANDING_BY) {
- prodCapability(getCapability(i), cap->running_task);
+ prodCapability(getCapability(i));
interruptCapability(getCapability(i));
}
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8585f8cb561e0ac1a995e1fd45ee52…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8585f8cb561e0ac1a995e1fd45ee52…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 2 commits: EPA: Remove LocatedP from CType
by Alan Zimmerman (＠alanz) 03 Jul '26
by Alan Zimmerman (＠alanz) 03 Jul '26
03 Jul '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
19cc63f2 by Alan Zimmerman at 2026-07-02T23:31:09+01:00
EPA: Remove LocatedP from CType
- - - - -
af438e12 by Alan Zimmerman at 2026-07-02T23:31:09+01:00
EPA: Remove LocatedP, last use in WarningTxt
- - - - -
12 changed files:
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Unit/Module/Warnings.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -299,7 +299,7 @@ ghcPrimWarns = WarnSome
[]
where
mk_txt msg =
- DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
+ DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
mk_decl_dep (occ, msg) = (occ, mk_txt msg)
ghcPrimFixities :: [(OccName,Fixity)]
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1162,7 +1162,7 @@ cidDeprecation :: forall p. IsPass p
cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } )
= depr
decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })
@@ -1360,7 +1360,7 @@ derivDeprecation :: forall p. IsPass p
derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
= depr
decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
@@ -1701,7 +1701,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO
type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO
-type instance Anno (CType (GhcPass p)) = SrcSpanAnnP
+type instance Anno (CType (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO
type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA
type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`ext2Q` located
`extQ` srcSpanAnnA
- `extQ` srcSpanAnnP
`extQ` srcSpanAnnN
`extQ` srcSpanAnnBF
@@ -404,9 +403,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc
srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
- srcSpanAnnP :: EpAnn AnnPragma -> SDoc
- srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
-
srcSpanAnnN :: EpAnn NameAnn -> SDoc
srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.EnforceEpt.TagSig
-import GHC.Parser.Annotation (noLocA)
+import GHC.Parser.Annotation (noLocA, noAnn)
import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc )
import GHC.Hs.Decls.Overlap ( OverlapFlag )
import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
@@ -664,8 +664,8 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
- IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -23,12 +23,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
-
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1705,15 +1705,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
| type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }
-capi_ctype :: { Maybe (LocatedP (CType GhcPs)) }
+capi_ctype :: { Maybe (LocatedA (CType GhcPs)) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2)))
- (getSTRING $3)))
- (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3)
+ (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn)
+ (Just (Header (getSTRINGs $2) (getSTRING $2)))
+ (getSTRING $3)))}
| '{-# CTYPE' STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2)))
- (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2)
+ (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn)
+ Nothing (getSTRING $2)))}
| { Nothing }
@@ -2073,11 +2075,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
: '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> $
+ DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)
+ (map stringLiteralToHsDocWst $ snd $ unLoc $2))}
| '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))
- (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
+ {% fmap Just $ amsA' (sLL $1 $> $
+ WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)
+ $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))}
| {- empty -} { Nothing }
warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
@@ -2106,7 +2110,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namespace_spec namelist strings
{% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
(Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3)
- (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
+ (WarningTxt (NoSourceText, noAnn) $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
namespace_spec :: { Located (NamespaceSpecifier GhcPs) }
: 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
@@ -2134,7 +2138,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namespace_spec namelist strings
{% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2)
- (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
+ (DeprecatedTxt (NoSourceText, noAnn) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) }
: STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -27,9 +27,9 @@ module GHC.Parser.Annotation (
EpAnnCO,
-- ** Annotations in 'GenLocated'
- LocatedA, LocatedN, LocatedAn, LocatedP,
+ LocatedA, LocatedN, LocatedAn,
LocatedE, LocatedBF,
- SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
+ SrcSpanAnnA, SrcSpanAnnN,
SrcSpanAnnBF,
-- ** Annotation data types used in 'GenLocated'
@@ -428,7 +428,6 @@ emptyComments = EpaComments []
type LocatedA = GenLocated SrcSpanAnnA
type LocatedN = GenLocated SrcSpanAnnN
-type LocatedP = GenLocated SrcSpanAnnP
type LocatedBF = GenLocated SrcSpanAnnBF
-- | Annotation for items appearing in a list. They can have one or
@@ -439,7 +438,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn]
-- on the context, such as backticks.
type SrcSpanAnnN = EpAnn NameAnn
-type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnBF = EpAnn AnnBooleanFormula
type LocatedE = GenLocated EpaLocation
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
mkTyData :: SrcSpan
-> Bool
-> NewOrData
- -> Maybe (LocatedP (CType GhcPs))
+ -> Maybe (LocatedA (CType GhcPs))
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
@@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
tcdDataDefn = defn,
tcdModifiers = [] })) }
-mkDataDefn :: Maybe (LocatedP (CType GhcPs))
+mkDataDefn :: Maybe (LocatedA (CType GhcPs))
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> DataDefnCons (LConDecl GhcPs)
@@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq
mkDataFamInst :: SrcSpan
-> NewOrData
- -> Maybe (LocatedP (CType GhcPs))
+ -> Maybe (LocatedA (CType GhcPs))
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -109,6 +109,7 @@ import Data.Data (Data)
import Data.Functor ((<&>))
import Control.DeepSeq (NFData(..))
+import GHC.Parser.Annotation (AnnPragma, noAnn)
{-
************************************************************************
@@ -213,11 +214,11 @@ instance Outputable CCallSpec where
defaultCType :: String -> CType (GhcPass p)
defaultCType =
- CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit
+ CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . fsLit
-mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
-mkCType x y m =
- CType (CTypeGhc x y) m
+mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
+mkCType x y ann m =
+ CType (CTypeGhc x y ann) m
typeCheckCType :: CType GhcRn -> CType GhcTc
typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z
@@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc
data CTypeGhc = CTypeGhc
{ cTypeSourceText :: SourceText
, cTypeOtherText :: SourceText
+ , cTypeAnn :: AnnPragma
}
deriving (Data, Eq)
@@ -356,6 +358,7 @@ instance Binary CTypeGhc where
return $ CTypeGhc
{ cTypeSourceText = str1
, cTypeOtherText = str2
+ , cTypeAnn = noAnn
}
instance NFData StaticTargetGhc where
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -156,8 +156,8 @@ warningTxtSame w1 w2
instance Outputable (InWarningCategory (GhcPass pass)) where
ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
-type instance XDeprecatedTxt (GhcPass _) = SourceText
-type instance XWarningTxt (GhcPass _) = SourceText
+type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma)
+type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma)
type instance XXWarningTxt (GhcPass _) = DataConCantHappen
type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
@@ -165,7 +165,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation
type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
type instance Anno (WarningCategory) = EpaLocation
-type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA
deriving stock instance Eq (WarningTxt GhcPs)
deriving stock instance Eq (WarningTxt GhcRn)
@@ -190,15 +190,15 @@ deriving instance Uniquable WarningCategory
instance Outputable (WarningTxt (GhcPass pass)) where
ppr (WarningTxt lsrc mcat ws)
= case lsrc of
- NoSourceText -> pp_ws ws
- SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ws
+ (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
ppr (DeprecatedTxt lsrc ds)
= case lsrc of
- NoSourceText -> pp_ws ds
- SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ds
+ (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}"
pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1558,26 +1558,26 @@ instance ExactPrint ModuleName where
-- ---------------------------------------------------------------------
-instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance ExactPrint (WarningTxt GhcPs) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do
+ exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do
o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws'))
+ return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws')
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
+ exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do
o' <- markAnnOpen'' o src "{-# DEPRECATED"
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
+ return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws')
instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where
getAnnotationEntry _ = NoEntryVal
@@ -4407,13 +4407,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where
-- ---------------------------------------------------------------------
-instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance Typeable p => ExactPrint (CType (GhcPass p)) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do
+ exact (CType ext mh ct) = do
let stp = cTypeSourceText ext
stct = cTypeOtherText ext
+ AnnPragma o c s l1 l2 t m = cTypeAnn ext
o' <- markAnnOpen'' o stp "{-# CTYPE"
l1' <- case mh of
Nothing -> return l1
@@ -4421,7 +4422,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct))
+ return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct)
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -835,7 +835,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF
type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA
-type instance Anno (CType DocNameI) = EpAnn AnnPragma
+type instance Anno (CType DocNameI) = SrcSpanAnnA
type instance Anno (Header DocNameI) = EpAnn AnnPragma
type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cedb075fcd3d01509d7c3eed20039b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cedb075fcd3d01509d7c3eed20039b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 3 commits: EPA: Remove LocatedP from OverlapMode
by Alan Zimmerman (＠alanz) 03 Jul '26
by Alan Zimmerman (＠alanz) 03 Jul '26
03 Jul '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
3555aee5 by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP from OverlapMode
- - - - -
b7559a99 by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP from CType
- - - - -
cedb075f by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP, last use in WarningTxt
- - - - -
18 changed files:
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Unit/Module/Warnings.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -299,7 +299,7 @@ ghcPrimWarns = WarnSome
[]
where
mk_txt msg =
- DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
+ DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
mk_decl_dep (occ, msg) = (occ, mk_txt msg)
ghcPrimFixities :: [(OccName,Fixity)]
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1162,7 +1162,7 @@ cidDeprecation :: forall p. IsPass p
cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } )
= depr
decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })
@@ -1272,20 +1272,25 @@ ppDerivStrategy mb =
Nothing -> empty
Just (L _ ds) -> ppr ds
-ppOverlapPragma :: Maybe (LocatedP (OverlapMode (GhcPass p))) -> SDoc
+ppOverlapPragma :: forall p. IsPass p => Maybe (LocatedA (OverlapMode (GhcPass p))) -> SDoc
ppOverlapPragma mb =
case mb of
Nothing -> empty
- Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}"
- Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
- Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}"
- Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}"
- Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
- Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet
+ Just (L _ (NoOverlap s)) -> maybe_stext (stext s) "{-# NO_OVERLAP #-}"
+ Just (L _ (Overlappable s)) -> maybe_stext (stext s) "{-# OVERLAPPABLE #-}"
+ Just (L _ (Overlapping s)) -> maybe_stext (stext s) "{-# OVERLAPPING #-}"
+ Just (L _ (Overlaps s)) -> maybe_stext (stext s) "{-# OVERLAPS #-}"
+ Just (L _ (Incoherent s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}"
+ Just (L _ (NonCanonical s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet
where
maybe_stext NoSourceText alt = text alt
maybe_stext (SourceText src) _ = ftext src <+> text "#-}"
+ stext :: XOverlapMode (GhcPass p) -> SourceText
+ stext s = case (ghcPass @p, s) of
+ (GhcPs, (s,_)) -> s
+ (GhcRn, (s,_)) -> s
+ (GhcTc, s) -> s
instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
@@ -1355,7 +1360,7 @@ derivDeprecation :: forall p. IsPass p
derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
= depr
decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
@@ -1696,7 +1701,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO
type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO
-type instance Anno (CType (GhcPass p)) = SrcSpanAnnP
+type instance Anno (CType (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO
type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA
type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
@@ -1711,7 +1716,7 @@ type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA
-type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnP
+type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnA
type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO
type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA
=====================================
compiler/GHC/Hs/Decls/Overlap.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Prelude
import GHC.Hs.Extension
+import GHC.Parser.Annotation ( AnnPragma )
+
import Language.Haskell.Syntax.Decls.Overlap
import Language.Haskell.Syntax.Extension
@@ -70,11 +72,13 @@ instance NFData OverlapFlag where
instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
-type instance XOverlapMode (GhcPass _) = SourceText
+type instance XOverlapMode GhcPs = (SourceText, AnnPragma)
+type instance XOverlapMode GhcRn = (SourceText, AnnPragma)
+type instance XOverlapMode GhcTc = SourceText
type instance XXOverlapMode (GhcPass _) = DataConCantHappen
-instance NFData (OverlapMode (GhcPass p)) where
+instance NFData (OverlapMode GhcTc) where
rnf = \case
NoOverlap s -> rnf s
Overlappable s -> rnf s
@@ -83,7 +87,7 @@ instance NFData (OverlapMode (GhcPass p)) where
Incoherent s -> rnf s
NonCanonical s -> rnf s
-instance Binary (OverlapMode (GhcPass p)) where
+instance Binary (OverlapMode GhcTc) where
put_ bh = \case
NoOverlap s -> putByte bh 0 >> put_ bh s
Overlaps s -> putByte bh 1 >> put_ bh s
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`ext2Q` located
`extQ` srcSpanAnnA
- `extQ` srcSpanAnnP
`extQ` srcSpanAnnN
`extQ` srcSpanAnnBF
@@ -404,9 +403,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc
srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
- srcSpanAnnP :: EpAnn AnnPragma -> SDoc
- srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
-
srcSpanAnnN :: EpAnn NameAnn -> SDoc
srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1750,7 +1750,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
NewtypeStrategy _ -> []
ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
-instance ToHie (LocatedP (OverlapMode GhcRn)) where
+instance ToHie (LocatedA (OverlapMode GhcRn)) where
toHie (L span _) = locOnly (locA span)
instance ToHie (LocatedA (ConDecl GhcRn)) where
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.EnforceEpt.TagSig
-import GHC.Parser.Annotation (noLocA)
+import GHC.Parser.Annotation (noLocA, noAnn)
import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc )
import GHC.Hs.Decls.Overlap ( OverlapFlag )
import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
@@ -664,8 +664,8 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
- IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -23,12 +23,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
-
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1469,15 +1469,15 @@ inst_decl :: { LInstDecl GhcPs }
(fmap reverse $7)
(AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}}
-overlap_pragma :: { Maybe (LocatedP (OverlapMode GhcPs)) }
- : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
- (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
- | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
- (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
- | '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
- (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
- | '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
- (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
+overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) }
+ : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1,
+ AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1,
+ AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ | '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1,
+ AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ | '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1,
+ AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
@@ -1705,15 +1705,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
| type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }
-capi_ctype :: { Maybe (LocatedP (CType GhcPs)) }
+capi_ctype :: { Maybe (LocatedA (CType GhcPs)) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2)))
- (getSTRING $3)))
- (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3)
+ (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn)
+ (Just (Header (getSTRINGs $2) (getSTRING $2)))
+ (getSTRING $3)))}
| '{-# CTYPE' STRING '#-}'
- {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2)))
- (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2)
+ (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn)
+ Nothing (getSTRING $2)))}
| { Nothing }
@@ -2073,11 +2075,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
: '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> $
+ DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)
+ (map stringLiteralToHsDocWst $ snd $ unLoc $2))}
| '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))
- (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
+ {% fmap Just $ amsA' (sLL $1 $> $
+ WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)
+ $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))}
| {- empty -} { Nothing }
warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
@@ -2106,7 +2110,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namespace_spec namelist strings
{% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
(Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3)
- (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
+ (WarningTxt (NoSourceText, noAnn) $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
namespace_spec :: { Located (NamespaceSpecifier GhcPs) }
: 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
@@ -2134,7 +2138,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namespace_spec namelist strings
{% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2)
- (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
+ (DeprecatedTxt (NoSourceText, noAnn) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) }
: STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -27,9 +27,9 @@ module GHC.Parser.Annotation (
EpAnnCO,
-- ** Annotations in 'GenLocated'
- LocatedA, LocatedN, LocatedAn, LocatedP,
+ LocatedA, LocatedN, LocatedAn,
LocatedE, LocatedBF,
- SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
+ SrcSpanAnnA, SrcSpanAnnN,
SrcSpanAnnBF,
-- ** Annotation data types used in 'GenLocated'
@@ -428,7 +428,6 @@ emptyComments = EpaComments []
type LocatedA = GenLocated SrcSpanAnnA
type LocatedN = GenLocated SrcSpanAnnN
-type LocatedP = GenLocated SrcSpanAnnP
type LocatedBF = GenLocated SrcSpanAnnBF
-- | Annotation for items appearing in a list. They can have one or
@@ -439,7 +438,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn]
-- on the context, such as backticks.
type SrcSpanAnnN = EpAnn NameAnn
-type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnBF = EpAnn AnnBooleanFormula
type LocatedE = GenLocated EpaLocation
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
mkTyData :: SrcSpan
-> Bool
-> NewOrData
- -> Maybe (LocatedP (CType GhcPs))
+ -> Maybe (LocatedA (CType GhcPs))
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
@@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
tcdDataDefn = defn,
tcdModifiers = [] })) }
-mkDataDefn :: Maybe (LocatedP (CType GhcPs))
+mkDataDefn :: Maybe (LocatedA (CType GhcPs))
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> DataDefnCons (LConDecl GhcPs)
@@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq
mkDataFamInst :: SrcSpan
-> NewOrData
- -> Maybe (LocatedP (CType GhcPs))
+ -> Maybe (LocatedA (CType GhcPs))
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -11,7 +11,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Handles @deriving@ clauses on @data@ declarations.
-module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
+module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..), tcOverlapMode ) where
import GHC.Prelude
@@ -776,12 +776,12 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo
tcOverlapMode :: OverlapMode GhcRn -> OverlapMode GhcTc
tcOverlapMode = \case
- NoOverlap s -> NoOverlap s
- Overlappable s -> Overlappable s
- Overlapping s -> Overlapping s
- Overlaps s -> Overlaps s
- Incoherent s -> Incoherent s
- NonCanonical s -> NonCanonical s
+ NoOverlap s -> NoOverlap (fst s)
+ Overlappable s -> Overlappable (fst s)
+ Overlapping s -> Overlapping (fst s)
+ Overlaps s -> Overlaps (fst s)
+ Incoherent s -> Incoherent (fst s)
+ NonCanonical s -> NonCanonical (fst s)
-- Typecheck the type in a standalone deriving declaration.
--
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -559,7 +559,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
-- Dfun location is that of instance *header*
; let warn = fmap unLoc lwarn
- ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
+ ; ispec <- newClsInst (fmap (tcOverlapMode . unLoc) overlap_mode) dfun_name
tyvars theta clas inst_tys warn
; let inst_binds = InstBindings
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -905,7 +905,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
************************************************************************
-}
-getOverlapFlag :: Maybe (OverlapMode (GhcPass p)) -- User pragma if any
+getOverlapFlag :: Maybe (OverlapMode GhcTc) -- User pragma if any
-> TcM OverlapFlag
-- Construct the OverlapFlag from the global module flags,
-- but if the overlap_mode argument is (Just m),
@@ -929,9 +929,9 @@ getOverlapFlag overlap_mode_prag
overlap_mode
| Just m <- overlap_mode_prag = m
- | incoherent_ok = Incoherent NoSourceText
- | overlap_ok = Overlaps NoSourceText
- | otherwise = NoOverlap NoSourceText
+ | incoherent_ok = Incoherent noAnn
+ | overlap_ok = Overlaps noAnn
+ | otherwise = NoOverlap noAnn
-- final_overlap_mode: the `-fspecialise-incoherents` flag controls the
-- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap
@@ -957,7 +957,7 @@ tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv
-newClsInst :: Maybe (OverlapMode (GhcPass p)) -- User pragma
+newClsInst :: Maybe (OverlapMode GhcTc) -- User pragma
-> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys warn
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -337,7 +337,6 @@ cvtDec (ClassD ctxt cl tvs fds decs)
}
cvtDec (InstanceD o ctxt ty decs)
- -- = do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs
= do { decs' <- cvt_ci_decs InstanceDecl decs
; let (fams', decls') = partitionWith is_fam_decl decs'
; for_ (nonEmpty fams') $ \ bad_fams ->
@@ -356,10 +355,10 @@ cvtDec (InstanceD o ctxt ty decs)
where
overlap pragma =
case pragma of
- TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS")
- TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE")
- TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING")
- TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT")
+ TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS", noAnn)
+ TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE", noAnn)
+ TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING", noAnn)
+ TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT", noAnn)
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -109,6 +109,7 @@ import Data.Data (Data)
import Data.Functor ((<&>))
import Control.DeepSeq (NFData(..))
+import GHC.Parser.Annotation (AnnPragma, noAnn)
{-
************************************************************************
@@ -213,11 +214,11 @@ instance Outputable CCallSpec where
defaultCType :: String -> CType (GhcPass p)
defaultCType =
- CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit
+ CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . fsLit
-mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
-mkCType x y m =
- CType (CTypeGhc x y) m
+mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
+mkCType x y ann m =
+ CType (CTypeGhc x y ann) m
typeCheckCType :: CType GhcRn -> CType GhcTc
typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z
@@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc
data CTypeGhc = CTypeGhc
{ cTypeSourceText :: SourceText
, cTypeOtherText :: SourceText
+ , cTypeAnn :: AnnPragma
}
deriving (Data, Eq)
@@ -350,12 +352,15 @@ instance Binary CTypeGhc where
put_ bh ct = do
put_ bh (cTypeSourceText ct)
put_ bh (cTypeOtherText ct)
+ put_ bh (cTypeAnn ct)
get bh = do
str1 <- get bh
str2 <- get bh
+ ann <- get bh
return $ CTypeGhc
{ cTypeSourceText = str1
, cTypeOtherText = str2
+ , cTypeAnn = ann
}
instance NFData StaticTargetGhc where
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -156,8 +156,8 @@ warningTxtSame w1 w2
instance Outputable (InWarningCategory (GhcPass pass)) where
ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
-type instance XDeprecatedTxt (GhcPass _) = SourceText
-type instance XWarningTxt (GhcPass _) = SourceText
+type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma)
+type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma)
type instance XXWarningTxt (GhcPass _) = DataConCantHappen
type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
@@ -165,7 +165,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation
type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
type instance Anno (WarningCategory) = EpaLocation
-type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA
deriving stock instance Eq (WarningTxt GhcPs)
deriving stock instance Eq (WarningTxt GhcRn)
@@ -190,15 +190,15 @@ deriving instance Uniquable WarningCategory
instance Outputable (WarningTxt (GhcPass pass)) where
ppr (WarningTxt lsrc mcat ws)
= case lsrc of
- NoSourceText -> pp_ws ws
- SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ws
+ (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
ppr (DeprecatedTxt lsrc ds)
= case lsrc of
- NoSourceText -> pp_ws ds
- SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ds
+ (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}"
pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1558,26 +1558,26 @@ instance ExactPrint ModuleName where
-- ---------------------------------------------------------------------
-instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance ExactPrint (WarningTxt GhcPs) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do
+ exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do
o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws'))
+ return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws')
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
+ exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do
o' <- markAnnOpen'' o src "{-# DEPRECATED"
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
+ return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws')
instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where
getAnnotationEntry _ = NoEntryVal
@@ -2248,40 +2248,40 @@ instance ExactPrint (TyFamInstDecl GhcPs) where
-- ---------------------------------------------------------------------
-instance Typeable p => ExactPrint (LocatedP (OverlapMode (GhcPass p))) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance ExactPrint (OverlapMode GhcPs) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
-- NOTE: NoOverlap is only used in the typechecker
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do
+ exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# NO_OVERLAP"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src))
+ return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m))
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do
+ exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPPABLE"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src))
+ return (Overlappable (src, AnnPragma o' c' s l1 l2 t m))
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do
+ exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPPING"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src))
+ return (Overlapping (src, AnnPragma o' c' s l1 l2 t m))
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do
+ exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPS"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src))
+ return (Overlaps (src, AnnPragma o' c' s l1 l2 t m))
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do
+ exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# INCOHERENT"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
+ return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do
+ exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do
o' <- markAnnOpen'' o src "{-# INCOHERENT"
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
+ return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
-- ---------------------------------------------------------------------
@@ -4407,13 +4407,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where
-- ---------------------------------------------------------------------
-instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance Typeable p => ExactPrint (CType (GhcPass p)) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
- exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do
+ exact (CType ext mh ct) = do
let stp = cTypeSourceText ext
stct = cTypeOtherText ext
+ AnnPragma o c s l1 l2 t m = cTypeAnn ext
o' <- markAnnOpen'' o stp "{-# CTYPE"
l1' <- case mh of
Nothing -> return l1
@@ -4421,7 +4422,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct))
+ return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct)
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -834,8 +834,8 @@ type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns
type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF
-type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma
-type instance Anno (CType DocNameI) = EpAnn AnnPragma
+type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA
+type instance Anno (CType DocNameI) = SrcSpanAnnA
type instance Anno (Header DocNameI) = EpAnn AnnPragma
type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e35…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e35…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/udfm-placement] Use a placement sort for deterministic UniqDFM iteration
by Simon Jakobi (＠sjakobi2) 02 Jul '26
by Simon Jakobi (＠sjakobi2) 02 Jul '26
02 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC
Commits:
1c645b9c by Simon Jakobi at 2026-07-02T21:26:00+02:00
Use a placement sort for deterministic UniqDFM iteration
eltsUDFM/udfmToList (and with them foldUDFM and UniqDFM's Foldable
instance) ordered elements with a list mergesort, allocating ~n*log n
cons cells per call. In the profile for the InstanceMatching1 perf test
this pipeline accounted for a large share of total allocations (#27459).
This commit instead uses a more efficient placement sort in most cases.
See Note [Sorting a UDFM].
Also add Note [Cost of deterministic iteration], prompted by #27459.
- - - - -
1 changed file:
- compiler/GHC/Types/Unique/DFM.hs
Changes:
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o
is not deterministic.
-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
{-# OPTIONS_GHC -Wall #-}
module GHC.Types.Unique.DFM (
@@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
+import GHC.Data.SmallArray
+import GHC.Exts (State#)
+import GHC.ST (ST(..), runST)
import Unsafe.Coerce
import qualified GHC.Data.Word64Set as W
@@ -92,9 +98,10 @@ import qualified GHC.Data.Word64Set as W
-- order then `udfmToList` returns them in deterministic order.
--
-- There is an implementation cost: each element is given a serial number
--- as it is added, and `udfmToList` sorts its result by this serial
--- number. So you should only use `UniqDFM` if you need the deterministic
--- property.
+-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their
+-- results by this serial number (see
+-- Note [Cost of deterministic iteration]). So you should only use `UniqDFM`
+-- if you need the deterministic property.
--
-- `foldUDFM` also preserves determinism.
--
@@ -112,13 +119,19 @@ import qualified GHC.Data.Word64Set as W
--
-- An alternative would be to have
--
--- data UniqDFM ele = UDFM (M.IntMap ele) [ele]
+-- data UniqDFM ele = UDFM (Word64Map ele) [ele]
--
-- where the list determines the order. This makes deletion tricky as we'd
-- only accumulate elements in that list, but makes merging easier as you
-- can just merge both structures independently.
-- Deletion can probably be done in amortized fashion when the size of the
-- list is twice the size of the set.
+--
+-- A representation like
+--
+-- data UniqDFM ele = UDFM (Word64Map ele) [Unique]
+--
+-- may also be worth considering. Compare Dhall.Map in the dhall package.
-- | A type of values tagged with insertion time
data TaggedVal val =
@@ -153,11 +166,15 @@ data UniqDFM key ele =
-- time. See Note [Overflow on plusUDFM]
deriving (Data, Functor)
--- | Deterministic, in O(n log n).
+-- | Deterministic.
+--
+-- See Note [Cost of deterministic iteration].
instance Foldable (UniqDFM key) where
foldr = foldUDFM
--- | Deterministic, in O(n log n).
+-- | Deterministic.
+--
+-- See Note [Cost of deterministic iteration].
instance Traversable (UniqDFM key) where
traverse f = fmap listToUDFM_Directly
. traverse (\(u,a) -> (u,) <$> f a)
@@ -310,13 +327,20 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
-- | Performs a deterministic fold over the UniqDFM.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- Don't use this to access the first element or to check for emptiness,
+-- as this already incurs most of the cost of returning the full list.
+-- See Note [Cost of deterministic iteration].
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldUDFM #-}
-- This INLINE prevents a regression in !10568
foldUDFM k z m = foldr k z (eltsUDFM m)
--- | Like 'foldUDFM' but the function also receives a key
+-- | Like 'foldUDFM' but the function also receives a key.
+--
+-- See Note [Cost of deterministic iteration].
foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldWithKeyUDFM #-}
-- This INLINE was copied from foldUDFM
@@ -331,14 +355,88 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
where
k' acc (TaggedVal v _) = k v acc
+-- Note [Cost of deterministic iteration]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Deterministic iteration orders elements by insertion tag, and any such
+-- ordering must inspect every element's tag before it can emit the first
+-- element. So even the head of the result costs a full traversal of the map
+-- plus -- on the main path -- the allocation of an O(n)-sized array (see
+-- Note [Sorting a UDFM]). Laziness in the result list only avoids allocating
+-- for elements that are never demanded; it does not make the iteration
+-- incremental. #27459 shows this cost biting in consumers that demanded only
+-- the head.
+--
+-- So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM;
+-- for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and
+-- if you don't need the deterministic order at all, use the nonDet functions.
+
+-- | Deterministic, in order of insertion.
+--
+-- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration].
eltsUDFM :: UniqDFM key elt -> [elt]
-{-# INLINE eltsUDFM #-}
--- The INLINE makes it a good producer (from the map)
-eltsUDFM (UDFM m _i) = map taggedFst (sort_it m)
+eltsUDFM (UDFM m i)
+ | n <= 1 = map taggedFst (M.elems m)
+ | usePlacement n i = placementSort i (M.elems m)
+ | otherwise = map taggedFst (sort_it m)
+ where n = M.size m
sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]
sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)
+
+-- Note [Sorting a UDFM]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- Deterministic iteration must order elements by insertion tag. Instead of a
+-- comparison sort -- the list mergesort behind sortBy allocates ~n*log n cons
+-- cells -- we exploit the invariant that in (UDFM m i) all tags are distinct
+-- Ints in [0, i): allocate an array of size i, write each element at
+-- @index = tag@, freeze, and read out in index order. That's O(i) work (which
+-- subsumes the O(n) fill, since distinct tags force n <= i), no comparisons,
+-- and the readout is lazy, so consumers that demand only a prefix pay almost
+-- nothing beyond the fill (but the fill itself is unavoidable; see
+-- Note [Cost of deterministic iteration]).
+--
+-- Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal
+-- with tag -1. Real tags are non-negative, so the readout skips on tag < 0;
+-- the sentinel's value field is never touched (it is unsafeCoerced ()).
+--
+-- This sorting method loses when i is much larger than n: i never shrinks
+-- (overwrites keep bumping it, delete/filter shrink n but not i). We compute
+-- n = M.size m (O(n), cheap next to either sort) and fall back to the
+-- mergesort when i > 4 * n. Maps built by plain insertion -- the common
+-- case -- have i == n. The guard also caps the fast path's O(i) at O(n).
+
+usePlacement :: Int -> Int -> Bool
+usePlacement n i = i <= 4 * n
+
+-- | Order a list of 'TaggedVal's by tag, by placing each at array index =
+-- its tag.
+--
+-- The tags must be distinct and in @[0, i)@.
+-- See Note [Sorting a UDFM].
+placementSort :: forall r. Int -> [TaggedVal r] -> [r]
+placementSort i tvs = runST (ST (\s0 ->
+ case newSmallArray i hole s0 of
+ (# s1, marr #) -> case fill marr tvs s1 of
+ s2 -> case unsafeFreezeSmallArray marr s2 of
+ (# s3, arr #) -> (# s3, readout arr 0 #)))
+ where
+ hole :: TaggedVal r
+ hole = TaggedVal (unsafeCoerce ()) (-1)
+
+ fill :: SmallMutableArray s (TaggedVal r) -> [TaggedVal r] -> State# s -> State# s
+ fill _ [] s = s
+ fill marr (tv : tvs') s =
+ case writeSmallArray marr (taggedSnd tv) tv s of
+ s' -> fill marr tvs' s'
+
+ readout :: SmallArray (TaggedVal r) -> Int -> [r]
+ readout arr j
+ | j >= i = []
+ | t < 0 = readout arr (j + 1)
+ | otherwise = v : readout arr (j + 1)
+ where TaggedVal v t = indexSmallArray arr j
+
filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
@@ -356,11 +454,26 @@ udfmRestrictKeysSet (UDFM val_set i) set =
in UDFM (M.restrictKeys val_set key_set) i
-- | Converts `UniqDFM` to a list, with elements in deterministic order.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- Don't use this to access the first element or to check for emptiness,
+-- as this already incurs most of the cost of returning the full list.
+-- See Note [Cost of deterministic iteration].
udfmToList :: UniqDFM key elt -> [(Unique, elt)]
-udfmToList (UDFM m _i) =
- [ (mkUniqueGrimily k, taggedFst v)
- | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+udfmToList (UDFM m i)
+ | n <= 1 = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ]
+
+ -- Unlike eltsUDFM, this allocates a fresh TaggedVal + pair per element
+ -- before the sort. If it ever matters, a parallel Word64 array of
+ -- keys filled in the same pass would avoid the eager boxes.
+ | usePlacement n i = placementSort i
+ (M.foldrWithKey (\k tv rest ->
+ TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv) : rest) [] m)
+ | otherwise =
+ [ (mkUniqueGrimily k, taggedFst v)
+ | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+ where n = M.size m
-- Determines whether two 'UniqDFM's contain the same keys.
equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c645b9c8d5318d36dd37c23c4abb6a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c645b9c8d5318d36dd37c23c4abb6a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/udfm-placement] Use a placement sort for deterministic UniqDFM iteration
by Simon Jakobi (＠sjakobi2) 02 Jul '26
by Simon Jakobi (＠sjakobi2) 02 Jul '26
02 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC
Commits:
a06b74dc by Simon Jakobi at 2026-07-02T20:41:07+02:00
Use a placement sort for deterministic UniqDFM iteration
eltsUDFM/udfmToList (and with them foldUDFM and UniqDFM's Foldable
instance) ordered elements with a list mergesort, allocating ~n*log n
cons cells per call. In the profile of InstanceMatching1 this pipeline
accounted for a large share of total allocations (#27459).
This commit instead uses a placement sort in most cases. See
Note [Sorting a UDFM].
Also add Note [Cost of deterministic iteration], prompted by #27459.
- - - - -
1 changed file:
- compiler/GHC/Types/Unique/DFM.hs
Changes:
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o
is not deterministic.
-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
{-# OPTIONS_GHC -Wall #-}
module GHC.Types.Unique.DFM (
@@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
+import GHC.Data.SmallArray
+import GHC.Exts (State#)
+import GHC.ST (ST(..), runST)
import Unsafe.Coerce
import qualified GHC.Data.Word64Set as W
@@ -92,9 +98,10 @@ import qualified GHC.Data.Word64Set as W
-- order then `udfmToList` returns them in deterministic order.
--
-- There is an implementation cost: each element is given a serial number
--- as it is added, and `udfmToList` sorts its result by this serial
--- number. So you should only use `UniqDFM` if you need the deterministic
--- property.
+-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their
+-- results by this serial number (see
+-- Note [Cost of deterministic iteration]). So you should only use `UniqDFM`
+-- if you need the deterministic property.
--
-- `foldUDFM` also preserves determinism.
--
@@ -112,13 +119,17 @@ import qualified GHC.Data.Word64Set as W
--
-- An alternative would be to have
--
--- data UniqDFM ele = UDFM (M.IntMap ele) [ele]
+-- data UniqDFM ele = UDFM (Word64Map ele) [ele]
--
-- where the list determines the order. This makes deletion tricky as we'd
-- only accumulate elements in that list, but makes merging easier as you
-- can just merge both structures independently.
-- Deletion can probably be done in amortized fashion when the size of the
-- list is twice the size of the set.
+--
+-- data UniqDFM ele = UDFM (Word64Map ele) [Unique]
+--
+-- may also be worth considering. Compare Dhall.Map in the dhall package.
-- | A type of values tagged with insertion time
data TaggedVal val =
@@ -153,11 +164,15 @@ data UniqDFM key ele =
-- time. See Note [Overflow on plusUDFM]
deriving (Data, Functor)
--- | Deterministic, in O(n log n).
+-- | Deterministic.
+--
+-- See Note [Cost of deterministic iteration].
instance Foldable (UniqDFM key) where
foldr = foldUDFM
--- | Deterministic, in O(n log n).
+-- | Deterministic.
+--
+-- See Note [Cost of deterministic iteration].
instance Traversable (UniqDFM key) where
traverse f = fmap listToUDFM_Directly
. traverse (\(u,a) -> (u,) <$> f a)
@@ -310,13 +325,20 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
-- | Performs a deterministic fold over the UniqDFM.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- Don't use this to access the first element or to check for emptiness,
+-- as this already incurs most of the cost of returning the full list.
+-- See Note [Cost of deterministic iteration].
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldUDFM #-}
-- This INLINE prevents a regression in !10568
foldUDFM k z m = foldr k z (eltsUDFM m)
--- | Like 'foldUDFM' but the function also receives a key
+-- | Like 'foldUDFM' but the function also receives a key.
+--
+-- See Note [Cost of deterministic iteration].
foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldWithKeyUDFM #-}
-- This INLINE was copied from foldUDFM
@@ -331,14 +353,90 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
where
k' acc (TaggedVal v _) = k v acc
+-- Note [Cost of deterministic iteration]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Deterministic iteration orders elements by insertion tag, and any such
+-- ordering must inspect every element's tag before it can emit the first
+-- element. So even the head of the result costs a full traversal of the map
+-- plus the allocation of an O(n)-sized array -- or, on the fallback path,
+-- O(n log n) cons cells (see Note [Sorting a UDFM]). Laziness in the result
+-- list only avoids allocating for elements that are never demanded; it does
+-- not make the iteration incremental. #27459 shows this cost biting in
+-- consumers that demanded only the head.
+--
+-- So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM;
+-- for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and
+-- if you don't need the deterministic order at all, use the nonDet functions.
+
+-- | Deterministic, in order of insertion.
+--
+-- See Notes [Sorting a UDFM] and [Cost of deterministic iteration].
eltsUDFM :: UniqDFM key elt -> [elt]
{-# INLINE eltsUDFM #-}
-- The INLINE makes it a good producer (from the map)
-eltsUDFM (UDFM m _i) = map taggedFst (sort_it m)
+eltsUDFM (UDFM m i)
+ | n <= 1 = map taggedFst (M.elems m)
+ | usePlacement n i = placementSort i (M.elems m)
+ | otherwise = map taggedFst (sort_it m)
+ where n = M.size m
sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]
sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)
+
+-- Note [Sorting a UDFM]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- Deterministic iteration must order elements by insertion tag. Instead of a
+-- comparison sort -- the list mergesort behind sortBy allocates ~n*log n cons
+-- cells -- we exploit the invariant that in (UDFM m i) all tags are distinct
+-- Ints in [0, i): allocate an array of size i, write each element at
+-- @index = tag@, freeze, and read out in index order. That's O(i) work (which
+-- subsumes the O(n) fill, since distinct tags force n <= i), no comparisons,
+-- and the readout is lazy, so consumers that demand only a prefix pay almost
+-- nothing beyond the fill (but the fill itself is unavoidable; see
+-- Note [Cost of deterministic iteration]).
+--
+-- Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal
+-- with tag -1. Real tags are non-negative, so the readout skips on tag < 0;
+-- the sentinel's value field is never touched (it is unsafeCoerced ()).
+--
+-- This sorting method loses when i is much larger than n: i never shrinks
+-- (overwrites keep bumping it, delete/filter shrink n but not i). We compute
+-- n = M.size m (O(n), cheap next to either sort) and fall back to the
+-- mergesort when i > 4 * n. Maps built by plain insertion -- the common
+-- case -- have i == n. The guard also caps the fast path's O(i) at O(n).
+
+usePlacement :: Int -> Int -> Bool
+usePlacement n i = i <= 4 * n
+
+-- | Order a list of 'TaggedVal's by tag, by placing each at array index =
+-- its tag.
+--
+-- The tags must be distinct and in @[0, i)@.
+-- See Note [Sorting a UDFM].
+placementSort :: forall r. Int -> [TaggedVal r] -> [r]
+placementSort i tvs = runST (ST (\s0 ->
+ case newSmallArray i hole s0 of
+ (# s1, marr #) -> case fill marr tvs s1 of
+ s2 -> case unsafeFreezeSmallArray marr s2 of
+ (# s3, arr #) -> (# s3, readout arr 0 #)))
+ where
+ hole :: TaggedVal r
+ hole = TaggedVal (unsafeCoerce ()) (-1)
+
+ fill :: SmallMutableArray s (TaggedVal r) -> [TaggedVal r] -> State# s -> State# s
+ fill _ [] s = s
+ fill marr (tv : tvs') s =
+ case writeSmallArray marr (taggedSnd tv) tv s of
+ s' -> fill marr tvs' s'
+
+ readout :: SmallArray (TaggedVal r) -> Int -> [r]
+ readout arr j
+ | j >= i = []
+ | t < 0 = readout arr (j + 1)
+ | otherwise = v : readout arr (j + 1)
+ where TaggedVal v t = indexSmallArray arr j
+
filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
@@ -356,11 +454,25 @@ udfmRestrictKeysSet (UDFM val_set i) set =
in UDFM (M.restrictKeys val_set key_set) i
-- | Converts `UniqDFM` to a list, with elements in deterministic order.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- Don't use this to access the first element or to check for emptiness,
+-- as this already incurs most of the cost of returning the full list.
+-- See Note [Cost of deterministic iteration].
udfmToList :: UniqDFM key elt -> [(Unique, elt)]
-udfmToList (UDFM m _i) =
- [ (mkUniqueGrimily k, taggedFst v)
- | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+udfmToList (UDFM m i)
+ | n <= 1 = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ]
+ -- Unlike eltsUDFM, this allocates a fresh TaggedVal + pair per element
+ -- before the sort. If it ever matters, a parallel Word64 array of
+ -- keys filled in the same pass would avoid the eager boxes.
+ | usePlacement n i = placementSort i
+ (M.foldrWithKey (\k tv rest ->
+ TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv) : rest) [] m)
+ | otherwise =
+ [ (mkUniqueGrimily k, taggedFst v)
+ | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+ where n = M.size m
-- Determines whether two 'UniqDFM's contain the same keys.
equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a06b74dc58af1433cb6d5a2c0952198…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a06b74dc58af1433cb6d5a2c0952198…
You're receiving this email because of your account on gitlab.haskell.org.
1
0