July 2026 - ghc-commits

[Git][ghc/ghc][wip/dcoutts/issue-26717] 44 commits: Coercion optimisation: avoid double-Sym for InstCo
by Duncan Coutts (＠dcoutts) 21 Jul '26

21 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/issue-26717 at Glasgow Haskell Compiler / GHC Commits: 722236dd by sheaf at 2026-07-18T08:48:31-04:00 Coercion optimisation: avoid double-Sym for InstCo Ticket #27374 pointed out an issue with GHC.Core.Coercion.Opt.optCoercion's handling of InstCo: it contravened (LC2) in Note [The LiftingContext in optCoercion] because it applied the ambient 'sym' to a coercion that was then added to the lifting context substitution. Fixes #27374 Co-authored-by: Simon Jakobi <simon.jakobi(a)gmail.com> - - - - - ff70fc75 by sheaf at 2026-07-18T08:48:31-04:00 Coercion optimisation: avoid exponential behaviour The change to coercion optimisation of 'InstCo' in the previous commit introduces exponential behaviour to the coercion optimiser. To avoid this, this commit provides a way to push in 'Sym' of an already-optimised coercion: GHC.Core.Coercion.Opt.mkDeepSymCo. See Note [Pushing Sym without re-optimising] in GHC.Core.Coercion.Opt. - - - - - dfef27f0 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Move THREADED_RTS-conditional struct members to end of Capability Accessing members of the Capability struct from CMM code rely on accessor macros. (The macros are generated by deriveConstants). These macros have a single definition. This means that the offsets of all struct members must *not* vary based on THREADED_RTS vs !THREADED_RTS. This requires that any struct members that are conditional on THREADED_RTS must occur after the unconditional struct members. Hence we move all the ones that are conditional on THREADED_RTS to the end. Add a deriveConstants entry for the iomgr member of the Capability struct, which was the motivation for this change. Add warning messages to help our future selves. Debugging this took me a couple hours in gdb! - - - - - c254e022 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Make the IOManager API use CapIOManager rather than Capability This makes the API somewhat more self-contained and more consistent. Now the IOManager API and each of the backends takes just the I/O manager structure. Previously we had a bit of a mixture, depending on whether the function needed access to the Capability or just the CapIOManager. We still need access to the cap, so we introduce a back reference to reach the capability, via iomgr->cap. Convert all uses in select and poll backends, but not win32 ones. Convert callers in the scheduler and elsewhere. Also convert the three CMM primops that call IOManager APIs. They just need to use Capability_iomgr(MyCapability()). - - - - - 4f3d8f31 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Split posix/MIO.c out of posix/Signals.c The MIO I/O manager was secretly living inside the Signals file. Now it gets its own file, like any other self-respecting I/O manager. - - - - - 52ce04a9 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Rationalise some scheduler run queue utilities Move them all to the same place in the file. Make some static that were used only internally. Also remove a redundant assignment after calling truncateRunQueue that is already done within truncateRunQueue. - - - - - 75bbdebc by Duncan Coutts at 2026-07-18T08:49:12-04:00 Rename initIOManager{AfterFork} to {re}startIOManager These are more accurate names, since these actions happen after initialisation and are really about starting (or restarting) background threads. - - - - - 724c0517 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Free per-cap I/O managers during shutdown and forkProcess Historically this was not strictly necessary. The select and win32 legacy I/O managers did not maintain any dynamically allocated resources. The new poll one does (an auxillary table), and so this should be freed. After forkProcess, all threads get deleted. This includes threads waiting on I/O or timers. So as of this patch, resetting the I/O manager is just about tidying things up. For example, for the poll I/O manager this will reset the size of the AIOP table (which otherwise grows but never shrinks). In future however the re-initialising will become neeecessary for functionality, since some I/O managers will need to re-initialise wakeup fds that are set CLOEXEC. - - - - - c007d122 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Add a TODO to the MIO I/O manager The direction of travel is to make I/O managers per-capability and have all their state live in the struct CapIOManager. The MIO I/O manager however still has a number of global variables. It's not obvious how handle these globals however. - - - - - b65ab7b3 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Add a FIXME note in the Poll I/O manager - - - - - daf2bd6f by Duncan Coutts at 2026-07-18T08:49:12-04:00 Add missing updateRemembSetPushClosure in poll I/O manager For the non-moving GC. - - - - - e33ca830 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Minor doc improvement to struct StgAsyncIOOp member outcome Mention the enumeration names, as well as their numeric values. The rest of the code uses the enum names. - - - - - 4edd2579 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Minor doc improvements for StgTSOBlockInfo Clarify that certain union members are used only by certain legacy I/O managers. Hopefully we will be able to remove these at some point. - - - - - 536bedbb by Duncan Coutts at 2026-07-18T08:49:12-04:00 Avoid exporting various win32-specific rts symbols The BeginPrivate.h / EndPrivate.h scheme works perfectly well on Windows, but all of the rts/win32/*.h files were not using it. - - - - - 8139b5ac by Duncan Coutts at 2026-07-18T08:49:12-04:00 Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd We no longer need wakeupIOManager for the threaded RTS case, so we can remove it and the bits only needed to support it. This includes the pipe/eventfd fd shared between the RTS and the in-library I/O manager used for waking up the I/O manager thread. The pipe/eventfd still exists, but it no longer has to be communicated to the RTS, since the RTS no longer needs to use it. So we remove the RTS API export setIOManagerWakeupFd, and remove uses of it within the I/O managers in ghc-internal. - - - - - 74fe7c66 by Duncan Coutts at 2026-07-18T08:49:12-04:00 Add a new interruptIOManager API for the I/O managers It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the return type and docs for awaitCompletedTimeoutsOrIO to have it return false when it gets interrupted, and have no useful post condition in that case. - - - - - 38792843 by Duncan Coutts at 2026-07-18T08:49:13-04:00 Add interruptIOManager support for select I/O manager Uses the FdWakup mechanism. - - - - - 2f3b00aa by Duncan Coutts at 2026-07-18T08:49:13-04:00 Add interruptIOManager support for poll I/O manager Uses the FdWakup mechanism. A quirk we have to cope with is that we now need to poll one more fd -- the wakeup_fd_r -- but this fd has no corresponding entry in the aiop_table. This is awkward since we have set up our aiop_poll_table to be an auxilliary table with matching indicies. The solution this patch uses (and described in the comments) is to have two tables: struct pollfd *aiop_poll_table, *full_poll_table; and to have the aiop_poll_table alias the tail of the full_poll_table. The head entry in the full_poll_table is the extra fd. So we poll the full_poll_table, while the aiop_poll_table still has matching indicies with the aiop_table. Hurrah for C aliasing rules. - - - - - cee50131 by Duncan Coutts at 2026-07-18T08:49:13-04:00 Add interruptIOManager support for win32 legacy I/O manager And remove unused related helper resetAbandonRequestWait. It is not called because the event is created in auto-reset mode, so never needs to be reset manually. - - - - - cf453143 by Duncan Coutts at 2026-07-18T08:49:13-04:00 Note lack of interruptIOManager support for WinIO I/O manager Though there's a plausible design, we can't sanely test it at the moment due to related WinIO bugs. Filed as issue #27403. - - - - - 1b74a0ad by Duncan Coutts at 2026-07-18T08:49:13-04:00 Be more explicit about enum IOReadOrWrite values, and type within cmm Belt and braces. - - - - - b388d093 by Brian McKenna at 2026-07-18T17:51:50-04:00 Ignore ticks in the pattern-match term oracle The term-oracle in the pattern-match checker is keyed by a canonical form of the scrutinee, computed by `makeDictsCoherent`. That canonical form was tick-sensitive: two occurrences of an otherwise identical expression that happened to carry different ticks were treated as distinct values, breaking long-distance information. This shows up in practice under `-finfo-table-map`, because the desugarer wraps every record-selector use site in a `SourceNote` carrying that site's span. For example: data Box = Box { unBox :: Maybe Int } f b = case unBox b of Nothing -> 0 Just _ -> let Just x = unBox b in x The two `unBox b` expressionss carry different SourceNote spans, the pattern-match checker sees them as different, the long-distance information from the outer `Just _` branch never reaches the let-pattern, and `Just x = unBox b` is wrongly reported as non-exhaustive. We now strip all ticks in `makeDictsCoherent`. This is documented as Wrinkle (UD1) of Note [Unique dictionaries in the TmOracle CoreMap]. Fixes #27314 - - - - - c23e1acb by Mrjtjmn at 2026-07-18T17:52:45-04:00 Add explanations for unsolved Typeable constraints This commit adds explanations for unsolved 'Typeable' constraints. GHC will now provide additional explanations for an unsolved constraint of the form 'Typeable ty', explain why GHC did not solve Typeable constraint. e.g.: - 'ty' is a polymorphic type (e.g. forall a. a -> a) - 'ty' is a qualified type (e.g. Eq Int => Int) - 'ty' is an unboxed sum type - 'ty' is an unreduced type family application - 'ty' whose kind is not typeable Fixes #26532 - - - - - cbef021e by Artem Pelenitsyn at 2026-07-19T07:49:55-04:00 ghc-internal: Lock.hs: fix typo and indentation - - - - - 42918646 by Duncan Coutts at 2026-07-19T07:50:36-04:00 Fix failing test GcStaticPointers for non-moving GC Minor mistake in asserting something before checking for that same thing. Specifically, Bdescr asserts HEAP_ALLOCED_GC, but Bdescr was being used prior to a guard that checks HEAP_ALLOCED_GC. The solution is just to move the use of Bdescr after the guard. Thanks to Simon Jakobi for identifying the problem. - - - - - 565c2554 by Duncan Coutts at 2026-07-21T01:22:14+01:00 Eliminate STM_AWOKEN It was used as nullary closure for the block_info.closure in the case of a thread being awoken after an STM transaction. However, while it was written, it was never read, so contributed nothing to the behaviour. Furthermore, in the only place it was set (in tryWakeupThread) the why_blocked was immediately overwritten by the NotBlocked status, and the block_info was updated accordingly (by appendToRunQueue). So it didn't even serve a purpose of clarifying an intermediate state, there really was no such intermediate state. Cleaning this up will allow the BlockedOnSTM case to follow the same pattern as the other why_blocked cases that do not use the block_info, and in turn this reduces the number of different categories. - - - - - c8bd011e by Duncan Coutts at 2026-07-21T01:22:14+01:00 Document that eventlog thread stop code ThreadBlocked is no longer used It has not been used since GHC 7.0.x (2011). In 7.2 all the BlockedOn* codes were added, and these were and are used instead of ThreadBlocked. - - - - - 4acb24c4 by Duncan Coutts at 2026-07-21T01:25:14+01:00 Add a proper mapping to eventlog external thread stop status That is the mapping from rts-internal codes, to the coes used in the status field in the eventlog EVENT_STOP_THREAD event. See issue #9003 for what goes wrong when we mess this up. In that ticket, people note that we should really not require the internal tso->why_blocked codes to leak into the external eventlog thread stop codes. The same principle applies to the StgThreadReturnCode. This change properly separates them, and explicitly maps between them using a pair of (compact, constant) tables. These tables are pretty small (with no alignment constraints) and will soon shrink so it seems a sensible tradeoff. We also introduce and use proper EVENT_STOP_THREAD constants in the event log format header. Previously there was not specification in the code for these (only in the docs): the values were encoded into the conversion code. This will allow us to renumber the internal why_blockd codes without breaking the eventlog output. - - - - - bc5f211f by Duncan Coutts at 2026-07-21T01:25:17+01:00 Remove unused tso->block_info.wakeup member. Presumably it was used once, but not now. - - - - - 4c722f11 by Duncan Coutts at 2026-07-21T01:29:34+01:00 Document StgTSOBlockInfo to say what cases use what members In principle, tso->why_blocked is the tag for the StgTSOBlockInfo union, so we should be able to say for each union member the why_blocked cases that use that member. - - - - - d08d988b by Duncan Coutts at 2026-07-21T01:29:37+01:00 Add a tso->block_info.mvar member and use it in preference to the generic block_info.closure union member, with casts. The plan is that when we know what case we're in (via tso->why_blocked) then we can always access the correct union member, and so we will only need to access block_info.closure for generic cases where we don't know or don't care. - - - - - 0d414ba9 by Duncan Coutts at 2026-07-21T01:29:37+01:00 Add a tso->block_info.unused member and use it in preference to the generic block_info.closure union member, with casts. The plan is that when we know what case we're in (via tso->why_blocked) then we can always access the correct union member, and so we will only need to access block_info.closure for generic cases where we don't know or don't care. - - - - - 0ed45905 by Duncan Coutts at 2026-07-21T01:31:39+01:00 Avoid storing to tso->block_info.closure In one case we can use a specific union member (.prev) instead. In several cases the stores were in fact redundant because of subsequent overwrites. In scavengeTSO we replace setting tso->block_info.closure to a valid closure, with an assertion that the block_info.unused is already set to END_TSO_QUEUE which is a valid (static) closure. - - - - - 306824c9 by Duncan Coutts at 2026-07-21T01:31:42+01:00 Renumber the tso->why_blocked constants We can do this now because we have separated the internal values from the external ones used in the eventlog. This lets us put them back into a deliberate order and consolodate some gaps. More importantly, it is a prepation for a slightly more sophisticated encoding. - - - - - 7cbb653d by Duncan Coutts at 2026-07-21T01:31:42+01:00 Define constants for the existing stg_threadStatuszh return codes The stg_threadStatuszh reuses the internal tso->why_blocked codes but also extends them with a couple previously magic values. This is awkward since we need to know what those magic values are so we don't accidentally use those values to mean something else. By pulling a definition up to where the why_blocked codes are defined we will be able to avoid mistakenly assining those codes some meaning (or just changing the BlockedThreadComplete, BlockedThreadKilled code if necessary). - - - - - 1e749764 by Duncan Coutts at 2026-07-21T01:31:42+01:00 Extend the tso->why_blocked encoding to indicate block_info closures We use some bit tricks to cheaply and generically test if a tso->why_blocked tag implies that the corresponding tso->block_info will contain a non-trivial valid closure (i.e. not just block_info.unused set to END_TSO_QUEUE). In particular we arrange for most why_blocked values to naturally have a distinguishing bit, but for the BlockedOn{Read,Write,Delay} cases, they can come in either non-closure or closure forms. We allow an additional bit to distinguish these cases. The non-closure forms are only from legacy I/O managers: select and win32-legacy. So this extra bit mechanism will be able to be retired once the legacy I/O managers are themselves retired. This means in a few places we need to untag the why_blocked value before inspecting it, but in most places we do not. - - - - - 45a2291f by Duncan Coutts at 2026-07-21T01:33:25+01:00 Use BlockInfoForceNonClosure in the select I/O manager - - - - - 56e1e50a by Duncan Coutts at 2026-07-21T01:33:28+01:00 Use BlockInfoForceNonClosure in the win32-legacy I/O manager for the BlockedOn{Read,Write} since these use the non-heap allocated StgAsyncIOResult. - - - - - 02687c66 by Duncan Coutts at 2026-07-21T01:33:29+01:00 Enforce the why_blocked and block_info rules in checkTSO We now check the cases wher IsBlockInfoClosure should hold, the cases that are supposed to use block_info.unused == END_TSO_QUEUE, and which cases are allowed to use BlockInfoForceNonClosure. This partially enforces the use of why_blocked as a tag for the block_info union. We could be stricter and check for the correct expected info table for the closure cases. - - - - - e29ede4b by Duncan Coutts at 2026-07-21T01:33:29+01:00 Use IsBlockInfoClosure to simplify several tests In GC and generic traversal we need to know if we should look at the block_info.closure or not. Now we can do just that using a cheap bit test on the why_blocked tag. This fixes issue 26717, where the problem was that some GC modes did not know when to look at block_info.closure, because the poll I/O manager uses a closure for BlockedOn{Read,Write} while the select I/O manager uses a non-closure. Now this information is in the why_blocked tag itself. - - - - - 834b7253 by Duncan Coutts at 2026-07-21T01:33:29+01:00 Remove the now-unused scavengeTSOIOManager The GC no longer has to delegate to the I/O manager, since it can use IsBlockInfoClosure to decide things itself. - - - - - bacf5f15 by Duncan Coutts at 2026-07-21T01:34:20+01:00 Remove duplicate assertion - - - - - acdc8a8b by Duncan Coutts at 2026-07-21T01:43:35+01:00 Follow atomic access rules more consistently for tso->why_blocked The rule is this: store block_info *before* why_blocked store why_blocked using store release load why_blocked using load acquire load block_info *after* why_blocked This is a an atomic store release / load acquire pair and (if the reads are in a separate thread to the writes, and the read receives the value stored) then this guarantees a full "happens before" relationship of these stores and loads. In some cases, we do not need a full load acquire, because we don't read the block_info at all and so do not need any ordering. In this case we just need an atomic relaxed load. This was being followed in most places, but not all. If there's good reason in any case that we don't need atomic access, then we should document that in a comment. In the absence of that I think it's easier to follow the rule everywhere. - - - - - e76e9134 by Duncan Coutts at 2026-07-21T01:43:37+01:00 Add a changelog entry - - - - - 78 changed files: - + changelog.d/T26532 - + changelog.d/T26716 - + changelog.d/T27314.md - + changelog.d/T27374 - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Instance/Typeable.hs - docs/users_guide/eventlog-formats.rst - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - rts/Capability.c - rts/Capability.h - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/RaiseAsync.h - rts/RtsStartup.c - rts/RtsSymbols.c - rts/STM.c - rts/Schedule.c - rts/Schedule.h - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Trace.c - rts/Trace.h - rts/TraverseHeap.c - rts/include/Cmm.h - rts/include/rts/Constants.h - rts/include/rts/EventLogFormat.h - rts/include/rts/IOInterface.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/posix/FdWakeup.h - + rts/posix/MIO.c - + rts/posix/MIO.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - rts/posix/Select.h - rts/posix/Signals.c - rts/posix/Signals.h - rts/posix/Timeout.c - rts/posix/Timeout.h - rts/rts.cabal - rts/sm/Compact.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - rts/win32/AsyncWinIO.h - rts/win32/AwaitEvent.c - rts/win32/AwaitEvent.h - rts/win32/ConsoleHandler.h - rts/win32/MIOManager.h - rts/win32/ThrIOManager.h - rts/win32/WorkQueue.h - rts/win32/veh_excn.h - + testsuite/tests/corelint/T27374.hs - testsuite/tests/corelint/all.T - + testsuite/tests/pmcheck/should_compile/T27314.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T15067.stderr - + testsuite/tests/typecheck/should_fail/T26532.hs - + testsuite/tests/typecheck/should_fail/T26532.stderr - testsuite/tests/typecheck/should_fail/T9858b.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2476509ee56feac50d886f5f81817d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2476509ee56feac50d886f5f81817d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Mark test T27105 as fragile, citing issue #27522
by Marge Bot (＠marge-bot) 20 Jul '26

20 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 196d1def by Duncan Coutts at 2026-07-20T19:44:20-04:00 Mark test T27105 as fragile, citing issue #27522 Scheduler fairness is fine, except when it isn't. And it isn't on CI machines surprisingly often! See the issue for details. - - - - - 2 changed files: - testsuite/tests/concurrent/should_run/T27105.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== testsuite/tests/concurrent/should_run/T27105.hs ===================================== @@ -12,15 +12,19 @@ import Prelude hiding (init) -- Test thread fairness: -- run two cpu-bound threads concurrently for a second, -- each counts how many operations it can perform until signaled to stop --- expect a balance between the two with no more than a 75% imperfection. --- Yes, 75%! On the CI machines we occasionally observe extraordinary levels --- of unfairness: nearly 60% in some cases. We don't want this to become a --- fragile test that is ignored, so we use an extreme bound. This should still --- catch gross breakage. +-- expect a balance between the two with no more than a 30% imperfection. -- --- This _should_ detect if the interval timer is not working, or if thread --- context switching is messed up. We can expect failure if we force a --- contex switch interval of more than half the test time, i.e. more than 0.5s +-- Sadly we have had to mark this test as fragile. On the CI machines we +-- occasionally observe extraordinary levels of unfairness: over 80% in some +-- cases. Having this marked fragile is not ideal, but it's no good having +-- random failures. See issue #27522. +-- +-- People working on the RTS timers, scheduler or capability infrastructure +-- *ought* to check this test is not failing badly in a reproducible way. +-- Doing so should still catch gross breakage. This test _should_ detect if +-- the interval timer is not working, or if thread context switching is messed +-- up. We can expect failure if we force a contex switch interval of more than +-- half the test time, i.e. more than 0.5s. -- -- We run the test twice, with allocating and non-allocating worker threads. -- The -fno-omit-yields above is crucial for worker_nonalloc below, or it never @@ -42,17 +46,16 @@ test worker = do threadDelay 300_000 -- Let them run for 300ms. The default context switch interval is 20ms. -- This gives time for 15 context switches, so this _should_ be enough - -- to get less than 10% unfairness. And on most platforms it is enough. - -- But OSX! Oh OSX! How do I loath thee? Let me count++ the ways. - -- To avoid a fragile test, we use a 75% unfairness threshold. + -- to get less than 10% unfairness. And on most platforms it is enough, + -- but for a bit of robustness we use 30%. putMVar stop () count1 <- takeMVar res1 count2 <- takeMVar res2 let balance :: Double balance = abs ((fromIntegral count1 - fromIntegral count2) / fromIntegral count2) - when (balance > 0.75) $ do - putStrLn "Schedule fairness more than 75% tolerance:" + when (balance > 0.30) $ do + putStrLn "Schedule fairness more than 30% tolerance:" putStrLn $ "imperfection: " ++ show (balance * 100) ++ "%" putStrLn $ "work counts: " ++ show (count1, count2) exitFailure ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -326,9 +326,10 @@ test('T26341b' , when(arch('wasm32') or arch('javascript'), skip) , compile_and_run, ['-package process']) -# Scheduler (very rough) fairness +# Scheduler fairness test('T27105', [when(arch('wasm32'), skip), # same reason as T367_letnoescape + fragile(27522), run_timeout_multiplier(0.05)], # we expect this to run for ~2s compile_and_run, ['']) test('T27105_fail', View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/196d1def04a9ed1b8f31ca5ccf5a13b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/196d1def04a9ed1b8f31ca5ccf5a13b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Mark test T27105 as fragile, citing issue #27522
by Marge Bot (＠marge-bot) 20 Jul '26

20 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: be115060 by Duncan Coutts at 2026-07-20T16:12:37-04:00 Mark test T27105 as fragile, citing issue #27522 Scheduler fairness is fine, except when it isn't. And it isn't on CI machines surprisingly often! See the issue for details. - - - - - 2 changed files: - testsuite/tests/concurrent/should_run/T27105.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== testsuite/tests/concurrent/should_run/T27105.hs ===================================== @@ -12,15 +12,19 @@ import Prelude hiding (init) -- Test thread fairness: -- run two cpu-bound threads concurrently for a second, -- each counts how many operations it can perform until signaled to stop --- expect a balance between the two with no more than a 75% imperfection. --- Yes, 75%! On the CI machines we occasionally observe extraordinary levels --- of unfairness: nearly 60% in some cases. We don't want this to become a --- fragile test that is ignored, so we use an extreme bound. This should still --- catch gross breakage. +-- expect a balance between the two with no more than a 30% imperfection. -- --- This _should_ detect if the interval timer is not working, or if thread --- context switching is messed up. We can expect failure if we force a --- contex switch interval of more than half the test time, i.e. more than 0.5s +-- Sadly we have had to mark this test as fragile. On the CI machines we +-- occasionally observe extraordinary levels of unfairness: over 80% in some +-- cases. Having this marked fragile is not ideal, but it's no good having +-- random failures. See issue #27522. +-- +-- People working on the RTS timers, scheduler or capability infrastructure +-- *ought* to check this test is not failing badly in a reproducible way. +-- Doing so should still catch gross breakage. This test _should_ detect if +-- the interval timer is not working, or if thread context switching is messed +-- up. We can expect failure if we force a contex switch interval of more than +-- half the test time, i.e. more than 0.5s. -- -- We run the test twice, with allocating and non-allocating worker threads. -- The -fno-omit-yields above is crucial for worker_nonalloc below, or it never @@ -42,17 +46,16 @@ test worker = do threadDelay 300_000 -- Let them run for 300ms. The default context switch interval is 20ms. -- This gives time for 15 context switches, so this _should_ be enough - -- to get less than 10% unfairness. And on most platforms it is enough. - -- But OSX! Oh OSX! How do I loath thee? Let me count++ the ways. - -- To avoid a fragile test, we use a 75% unfairness threshold. + -- to get less than 10% unfairness. And on most platforms it is enough, + -- but for a bit of robustness we use 30%. putMVar stop () count1 <- takeMVar res1 count2 <- takeMVar res2 let balance :: Double balance = abs ((fromIntegral count1 - fromIntegral count2) / fromIntegral count2) - when (balance > 0.75) $ do - putStrLn "Schedule fairness more than 75% tolerance:" + when (balance > 0.30) $ do + putStrLn "Schedule fairness more than 30% tolerance:" putStrLn $ "imperfection: " ++ show (balance * 100) ++ "%" putStrLn $ "work counts: " ++ show (count1, count2) exitFailure ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -326,9 +326,10 @@ test('T26341b' , when(arch('wasm32') or arch('javascript'), skip) , compile_and_run, ['-package process']) -# Scheduler (very rough) fairness +# Scheduler fairness test('T27105', [when(arch('wasm32'), skip), # same reason as T367_letnoescape + fragile(27522), run_timeout_multiplier(0.05)], # we expect this to run for ~2s compile_and_run, ['']) test('T27105_fail', View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be115060b147bc4117cfd28313fa0d4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be115060b147bc4117cfd28313fa0d4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/better-show-iface-documentation
by Wolfgang Jeltsch (＠jeltsch) 20 Jul '26

20 Jul '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/better-show-iface-documentation at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/better-show-iface-doc… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Add user documentation
by Wolfgang Jeltsch (＠jeltsch) 20 Jul '26

20 Jul '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 12d74b58 by Wolfgang Jeltsch at 2026-07-20T21:33:32+03:00 Add user documentation - - - - - 1 changed file: - docs/users_guide/using.rst Changes: ===================================== docs/users_guide/using.rst ===================================== @@ -417,6 +417,13 @@ The available mode flags are: Read the interface in ⟨file⟩ and dump it as text to ``stdout``. For example ``ghc --show-iface M.hi``. +.. ghc-flag:: --show-bytecode ⟨file⟩ + :shortdesc: display contents of a bytecode file. + :type: mode + :category: modes + + Read a bytecode file and dump relevant parts of it as text to ``stdout``. + .. ghc-flag:: --supported-extensions --supported-languages :shortdesc: display the supported language extensions View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12d74b588fdee0f0bb129bafc4c6c2c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12d74b588fdee0f0bb129bafc4c6c2c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/nonmoving-gc-timeout] testsuite: Skip broken DoubleX2 tests in nonmoving ways
by Simon Jakobi (＠sjakobi2) 20 Jul '26

20 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/nonmoving-gc-timeout at Glasgow Haskell Compiler / GHC Commits: 2d3e3b5b by Simon Jakobi at 2026-07-20T20:24:11+02:00 testsuite: Skip broken DoubleX2 tests in nonmoving ways The DoubleX2 arithmetic tests leave half of their output buffers uninitialised. Nonmoving GC ways expose these values, resulting in very large unexpected-output diffs. Temporarily omit these tests from all nonmoving ways while retaining coverage in the other test ways. Assisted-by: gpt-5.6-sol via Codex CLI - - - - - 1 changed file: - testsuite/tests/simd/should_run/all.T Changes: ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -16,6 +16,12 @@ setTestOpts( , omit_ghci ]) +# These tests currently leave half of their output buffers uninitialised. The +# nonmoving ways expose this and produce very large diffs. +omit_nonmoving_doublex2 = omit_ways( + ['nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc', + 'nonmoving_thr_sanity']) + # The code generator may emit different instructions depending on # the architecture options (e.g. SSE2 vs SSE4.1 vs AVX). # Ideally, all ISA levels should be tested, but doing so would @@ -33,7 +39,7 @@ test('word16x8_basic_baseline', [], compile_and_run, ['']) test('word32x4_basic_baseline', [], compile_and_run, ['']) test('word64x2_basic_baseline', [], compile_and_run, ['']) test('floatx4_arith_baseline', [], compile_and_run, ['']) -test('doublex2_arith_baseline', [], compile_and_run, ['']) +test('doublex2_arith_baseline', [omit_nonmoving_doublex2], compile_and_run, ['']) test('floatx4_shuffle_baseline', [], compile_and_run, ['']) test('doublex2_shuffle_baseline', [], compile_and_run, ['']) test('int8x16_arith_baseline', [], compile_and_run, ['']) @@ -126,15 +132,17 @@ test('word16x8_basic', [], compile_and_run, ['']) test('word32x4_basic', [], compile_and_run, ['']) test('word64x2_basic', [], compile_and_run, ['']) test('floatx4_arith', [], compile_and_run, ['']) -test('doublex2_arith', [], compile_and_run, ['']) +test('doublex2_arith', [omit_nonmoving_doublex2], compile_and_run, ['']) test('floatx4_shuffle', [], compile_and_run, ['']) test('doublex2_shuffle', [], compile_and_run, ['']) test('floatx4_fma', [ unless(have_cpu_feature('fma') or arch('aarch64'), skip) , extra_hc_opts('-mfma') ], compile_and_run, ['']) -test('doublex2_fma', [ unless(have_cpu_feature('fma') or arch('aarch64'), skip) - , extra_hc_opts('-mfma') - ], compile_and_run, ['']) +test('doublex2_fma', + [ unless(have_cpu_feature('fma') or arch('aarch64'), skip) + , extra_hc_opts('-mfma') + , omit_nonmoving_doublex2 + ], compile_and_run, ['']) test('int8x16_arith', [], compile_and_run, ['']) test('int16x8_arith', [], compile_and_run, ['']) test('int32x4_arith', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d3e3b5b80cf1d56e49f95870aa06f1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d3e3b5b80cf1d56e49f95870aa06f1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/supersven/hadrian-cross-stage3] 9 commits: WIP bindist note
by Sven Tennie (＠supersven) 20 Jul '26

20 Jul '26

Sven Tennie pushed to branch wip/supersven/hadrian-cross-stage3 at Glasgow Haskell Compiler / GHC Commits: d4acb9e2 by GHC GitLab CI at 2026-07-18T09:24:50+02:00 WIP bindist note - - - - - c1947e80 by GHC GitLab CI at 2026-07-20T18:54:51+02:00 Improve Haddock - - - - - c327d249 by GHC GitLab CI at 2026-07-20T18:54:59+02:00 Imporve bindist - - - - - 7174bf40 by GHC GitLab CI at 2026-07-20T18:55:10+02:00 Fix Haddock - - - - - 63d1b2e0 by GHC GitLab CI at 2026-07-20T19:21:23+02:00 WIP - - - - - cf2d3ed7 by GHC GitLab CI at 2026-07-20T19:26:23+02:00 A - - - - - 4bb4b5a5 by GHC GitLab CI at 2026-07-20T19:34:26+02:00 Typos - - - - - 5aa97592 by GHC GitLab CI at 2026-07-20T20:00:35+02:00 Simplify - - - - - 6ec8857c by GHC GitLab CI at 2026-07-20T20:03:13+02:00 Formatting - - - - - 3 changed files: - hadrian/src/BindistConfig.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== hadrian/src/BindistConfig.hs ===================================== @@ -24,7 +24,7 @@ crossBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage1 targetBindist :: BindistConfig targetBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage2 } --- | Parent folder under build root ("bindist" or "bindist-stage3") +-- | Folder relative to build root ("bindist" or "bindist-stage3") bindistFolder :: BindistConfig -> FilePath bindistFolder conf | executable_stage conf == Stage2 = "bindist-stage3" bindistFolder _conf = "bindist" ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -19,66 +19,83 @@ import BindistConfig Note [Binary distributions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Hadrian produces binary distributions under: +Hadrian produces binary distributions that run on the build host architecture +(build == host, target == host || target /= host) under: <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz -For stage3 (target) bindists, a separate parent folder is used: +For stage3 (build /= host, host == target) bindists, a separate parent folder +is used: <build root>/bindist-stage3/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz -The stage2/cross bindist is generated by creating an archive from: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/ +While regular bindists are usual same-arch compilers or cross-compilers, stage3 +bindists are cross-compiled compilers. -The stage3/target bindist is generated by creating an archive from: - <build root>/bindist-stage3/ghc-<X>.<Y>.<Z>-<arch>-<os>/ +Bindists are generated by creating an archive from: + <build root>/<bindist|bindist-stage3>/ghc-<X>.<Y>.<Z>-<arch>-<os>/ -It does so by following the steps below. +Stage2 cross-compilers are a by-product of creating stage3 cross-compiled +compilers. The additional build dir (bindist-stage3) lets us keep both, such +that we can build them in one go on CI. +Configuration files (e.g. configure script and default.host.target) differ in +this case and keeping both targets separated also saves us some headache +dealing with stale files. -- make sure we have a complete stage 2 compiler + haddock +This table introduces variables to simplify the following step descriptions: + +| compiler kind | <bindist-dir> | <executable-stage-dir> | <library-stage-dir> | +|------------------|----------------|------------------------|---------------------| +| native | bindist | stage1/ | stage1/ | +| cross compiler | bindist | stage1/ | stage2/ | +| cross-compiled | bindist-stage3 | stage2/ | stage2/ | + +These are the steps to build a bindist: + +- make sure we have a complete compiler + libraries + haddock for the stage(s) + to bundle - copy the specific binaries which should be in the bindist to the bin folder and add the version suffix: - <build root>/stage1/bin/xxxx + <build root>/<executable-stage-dir>/bin/xxxx to - <build root/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/xxxx-<VER> + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/[<target>-]xxxx-<VER> + where the optional <target>- prefix is the cross triple for cross-compilers. - create symlink (or bash) wrapper from unversioned to versioned executable: - <build root/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/xxxx + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/[<target>-]xxxx points to: - <build root/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/xxxx-<VER> + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/[<target>-]xxxx-<VER> - copy the lib directories of the compiler we built: - <build root>/stage1/lib + <build root>/<library-stage-dir>/lib to - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/lib + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/lib - copy the generated docs (user guide, haddocks, etc): - <build root>/docs/ + <build root>/doc/ to - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/docs/ + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/doc/ -- use autoreconf to generate per-stage `configure` scripts from - aclocal.m4 and stage1/distrib/configure.ac (for cross/compiler bindists) or - stage2/distrib/configure.ac (for target-native bindists), that we move to: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/configure - <build root>/bindist-stage3/ghc-<X>.<Y>.<Z>-<arch>-<os>/configure +- use autoreconf to generate a staged `configure` script in + <build root>/<executable-stage>/distrib + that we move to: + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/configure - write a (fixed) Makefile capable of supporting 'make install' to: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/Makefile + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/Makefile - write some (fixed) supporting bash code for the wrapper scripts to: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/wrappers/<program> + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/wrappers/<program> where <program> is the name of the executable that the bash file will help wrapping. -- copy supporting configure/make related files - (see @bindistInstallFiles@) to: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/<file> +- copy supporting configure/make related files (see @bindistInstallFiles@) to: + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/<file> - create a .tar.xz archive of the directory: - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/ + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>/ at - <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz + <build root>/<bindist-dir>/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz Note [Wrapper scripts and binary distributions] ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -567,7 +567,7 @@ generateSettings settingsFile includeLibDir rel_pkg_db compilerStage = do stage <- getStage -- The unit-id of the base package which is always linked against (#25382). - -- For stage2 cross compilers the target libraries live in the stage2 lib + -- For stage2 cross compilers the target libraries live in the stage3 lib -- dir, so the base unit-id must come from stage2; for native stage2 the -- libraries live in the stage1 lib dir. base_unit_id <- expr $ do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/287b8a8c88a88036b20ea2e548273c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/287b8a8c88a88036b20ea2e548273c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/TTG-No-Orphans] Resolving many TTG related orphan type-class instances
by recursion-ninja (＠recursion-ninja) 20 Jul '26

20 Jul '26

recursion-ninja pushed to branch wip/TTG-No-Orphans at Glasgow Haskell Compiler / GHC Commits: 76401e72 by Recursion Ninja at 2026-07-20T13:37:00-04:00 Resolving many TTG related orphan type-class instances This is part a technical debt removal effort made possible now that separating out the AST via TTG has come to a close. As the AST in 'L.H.S' has been incrementally separated from the GHC internals, there are many accumulated orphan instance of 'Binary', 'NFData', 'Outputable', and 'Uniquable'. The orphan instance of data-types from within 'L.H.S' have had their orphan instances moved to either: 1. The module which defines the data-type 2. The module which defines the type-class; i.e. moving an orphan 'Binary' instance to 'GHC.Utils.Binary' Orphan instances resolved (37): | Data-type | Resolved instance(s) | Former orphan module(s) | | -------------------- | -------------------------- | ------------------------- | | Role | Binary, NFData, Outputable | GHC.Core.Coercion.Axiom | | SrcStrictness | Binary, NFData, Outputable | GHC.Core.DataCon | | SrcUnpackedness | Binary, NFData, Outputable | GHC.Core.DataCon | | Fixity | Binary, Outputable | GHC.Hs.Basic | | FixityDirection | Binary, Outputable | GHC.Hs.Basic | | LexicalFixity | Outputable | GHC.Hs.Basic | | CCallTarget | NFData | GHC.Hs.Decls.Foreign | | CType | NFData | GHC.Hs.Decls.Foreign | | Header | NFData | GHC.Hs.Decls.Foreign | | OverlapMode | Binary, NFData | GHC.Hs.Decls.Overlap | | WithHsDocIdentifiers | NFData, Outputable | GHC.Hs.Doc | | HsDocString | NFData | GHC.Hs.DocString | | HsDocStringChunk | Binary, Outputable | GHC.Hs.DocString | | HsDocStringDecorator | Binary, Outputable | GHC.Hs.DocString | | NamespaceSpecifier | Outputable | GHC.Hs.ImpExp | | ForAllTyFlag | Binary, NFData, Outputable | GHC.Hs.Specificity | | Specificity | Binary, NFData | GHC.Hs.Specificity | | PromotionFlag | Binary, Outputable | GHC.Types.Basic | | FieldLabelString | Outputable, Uniquable | GHC.Types.FieldLabel | | InlinePragma | Binary | GHC.Types.InlinePragma | ------------------------- Metric Decrease: hard_hole_fits ------------------------- Closes #21262, #27469 - - - - - 26 changed files: - compiler/GHC/Core/Coercion/Axiom.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/ImpExp.hs - − compiler/GHC/Hs/Specificity.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/FieldLabel.hs - compiler/GHC/Types/Fixity.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Specificity.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Core/Coercion/Axiom.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable - -- (c) The University of Glasgow 2012 -- | Module for coercion axioms, used to represent type family instances @@ -22,7 +20,7 @@ module GHC.Core.Coercion.Axiom ( coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, - Role(..), fsFromRole, + Role(..), CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn, coAxiomRuleArgRoles, coAxiomRuleRole, @@ -43,7 +41,6 @@ import GHC.Types.Name import GHC.Types.Unique import GHC.Types.Var import GHC.Utils.Misc -import GHC.Utils.Binary import GHC.Utils.Panic import GHC.Data.Pair import GHC.Types.Basic @@ -52,7 +49,6 @@ import GHC.Types.SrcLoc import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) -import Control.DeepSeq {- Note [Coercion axiom branches] @@ -521,44 +517,6 @@ instance Outputable CoAxBranch where , ppUnless (null incomps) $ text "incomps:" <+> vcat (map ppr incomps) ]) -{- -************************************************************************ -* * - Roles -* * -************************************************************************ - -Roles are defined here to avoid circular dependencies. --} - --- These names are slurped into the parser code. Changing these strings --- will change the **surface syntax** that GHC accepts! If you want to --- change only the pretty-printing, do some replumbing. See --- mkRoleAnnotDecl in GHC.Parser.PostProcess -fsFromRole :: Role -> FastString -fsFromRole Nominal = fsLit "nominal" -fsFromRole Representational = fsLit "representational" -fsFromRole Phantom = fsLit "phantom" - -instance Outputable Role where - ppr = ftext . fsFromRole - -instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) - -instance NFData Role where - rnf Nominal = () - rnf Representational = () - rnf Phantom = () - {- ************************************************************************ * * ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -5,8 +5,6 @@ \section[DataCon]{@DataCon@: Data Constructors} -} -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary - module GHC.Core.DataCon ( -- * Main data types DataCon, DataConRep(..), @@ -109,7 +107,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Data as Data import Data.Char import Data.List( find ) -import Control.DeepSeq {- Note [Data constructor representation] @@ -1030,16 +1027,6 @@ instance Outputable HsImplBang where ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b) -instance Outputable SrcStrictness where - ppr SrcLazy = char '~' - ppr SrcStrict = char '!' - ppr NoSrcStrict = empty - -instance Outputable SrcUnpackedness where - ppr SrcUnpack = text "{-# UNPACK #-}" - ppr SrcNoUnpack = text "{-# NOUNPACK #-}" - ppr NoSrcUnpack = empty - instance Outputable StrictnessMark where ppr MarkedStrict = text "!" ppr NotMarkedStrict = empty @@ -1054,40 +1041,6 @@ instance Binary StrictnessMark where 1 -> return MarkedStrict _ -> panic "Invalid binary format" -instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcLazy - 1 -> return SrcStrict - _ -> return NoSrcStrict - -instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcNoUnpack - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - -instance NFData SrcStrictness where - rnf SrcLazy = () - rnf SrcStrict = () - rnf NoSrcStrict = () - -instance NFData SrcUnpackedness where - rnf SrcNoUnpack = () - rnf SrcUnpack = () - rnf NoSrcUnpack = () - -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True ===================================== compiler/GHC/Hs/Basic.hs ===================================== @@ -1,52 +1,6 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary -{-# LANGUAGE TypeFamilies #-} - -- | Fixity module GHC.Hs.Basic ( module Language.Haskell.Syntax.Basic ) where -import GHC.Prelude - -import GHC.Utils.Outputable -import GHC.Utils.Binary - import Language.Haskell.Syntax.Basic - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - -instance Outputable Fixity where - ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] - - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - ------------------------- - -instance Binary FixityDirection where - put_ bh InfixL = - putByte bh 0 - put_ bh InfixR = - putByte bh 1 - put_ bh InfixN = - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return InfixL - 1 -> return InfixR - _ -> return InfixN ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -1,12 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- Necessary for the following instances: - * (type class): Binary OverlapMode - * (type class): NFData OverlapMode --} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- XOverlapMode, XXOverlapMode {- | Data-types describing the overlap annotations for instances as well as @@ -74,34 +69,6 @@ type instance XOverlapMode (GhcPass _) = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen -instance NFData (OverlapMode (GhcPass p)) where - rnf = \case - NoOverlap s -> rnf s - Overlappable s -> rnf s - Overlapping s -> rnf s - Overlaps s -> rnf s - Incoherent s -> rnf s - NonCanonical s -> rnf s - -instance Binary (OverlapMode (GhcPass p)) where - put_ bh = \case - NoOverlap s -> putByte bh 0 >> put_ bh s - Overlaps s -> putByte bh 1 >> put_ bh s - Incoherent s -> putByte bh 2 >> put_ bh s - Overlapping s -> putByte bh 3 >> put_ bh s - Overlappable s -> putByte bh 4 >> put_ bh s - NonCanonical s -> putByte bh 5 >> put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= \s -> return $ NoOverlap s - 1 -> get bh >>= \s -> return $ Overlaps s - 2 -> get bh >>= \s -> return $ Incoherent s - 3 -> get bh >>= \s -> return $ Overlapping s - 4 -> get bh >>= \s -> return $ Overlappable s - _ -> get bh >>= \s -> return $ NonCanonical s - pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = text "[safe]" pprSafeOverlap False = empty ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -63,16 +63,6 @@ type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass p deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass) deriving instance (Eq (LIdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where - rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i) - --- | For compatibility with the existing @-ddump-parsed' output, we only show --- the docstring. --- --- Use 'pprHsDoc' to show `HsDoc`'s internals. -instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where - ppr (WithHsDocIdentifiers s _ids) = ppr s - instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -5,6 +5,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +-- Binary HsDocString +-- Outputable HsDocString module GHC.Hs.DocString ( LHsDocString @@ -44,7 +46,6 @@ import GHC.Hs.Extension.Pass (GhcPass, GhcPs, GhcRn, GhcTc) import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension -import Control.DeepSeq import Data.Data import Data.List.NonEmpty (NonEmpty(..)) import Data.List (intercalate) @@ -82,11 +83,6 @@ instance (Show (LHsDocStringChunk pass), XXHsDocString pass ~ DataConCantHappen) instance Outputable (HsDocString (GhcPass p)) where ppr = text . renderHsDocString -instance NFData (HsDocString (GhcPass p)) where - rnf (MultiLineDocString _ a b) = rnf a `seq` rnf b - rnf (NestedDocString _ a b) = rnf a `seq` rnf b - rnf (GeneratedDocString _ a) = rnf a - -- | Annotate a pretty printed thing with its doc. -- The docstring comes after if it is 'HsDocStringPrevious'. -- Otherwise it comes before. @@ -120,37 +116,12 @@ instance Binary (HsDocString (GhcPass p)) where 2 -> GeneratedDocString noExtField <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t -instance Outputable HsDocStringDecorator where - ppr = text . printDecorator - printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" printDecorator HsDocStringPrevious = "^" printDecorator (HsDocStringNamed n) = '$':n printDecorator (HsDocStringGroup n) = replicate n '*' -instance Binary HsDocStringDecorator where - put_ bh x = case x of - HsDocStringNext -> putByte bh 0 - HsDocStringPrevious -> putByte bh 1 - HsDocStringNamed n -> putByte bh 2 >> put_ bh n - HsDocStringGroup n -> putByte bh 3 >> put_ bh n - get bh = do - tag <- getByte bh - case tag of - 0 -> pure HsDocStringNext - 1 -> pure HsDocStringPrevious - 2 -> HsDocStringNamed <$> get bh - 3 -> HsDocStringGroup <$> get bh - t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t - -instance Binary HsDocStringChunk where - put_ bh (HsDocStringChunk bs) = put_ bh bs - get bh = HsDocStringChunk <$> get bh - -instance Outputable HsDocStringChunk where - ppr = text . unpackHDSC - mkGeneratedHsDocStringGhc :: String -> HsDocString (GhcPass p) mkGeneratedHsDocStringGhc = mkGeneratedHsDocString noExtField . mkHsDocStringChunk ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -447,8 +447,3 @@ coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace filterByNamespaceSpecifierGREs :: NamespaceSpecifier (GhcPass p) -> [GlobalRdrElt] -> [GlobalRdrElt] filterByNamespaceSpecifierGREs NoNamespaceSpecifier{} = id filterByNamespaceSpecifierGREs ns_spec = filterByNamespaceGREs (coveredByNamespaceSpecifier ns_spec) - -instance Outputable (NamespaceSpecifier (GhcPass p)) where - ppr NoNamespaceSpecifier{} = empty - ppr TypeNamespaceSpecifier{} = text "type" - ppr DataNamespaceSpecifier{} = text "data" ===================================== compiler/GHC/Hs/Specificity.hs deleted ===================================== @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -module GHC.Hs.Specificity where - -import Prelude -import Control.DeepSeq (NFData(..)) - -import GHC.Utils.Outputable -import GHC.Utils.Binary - -import Language.Haskell.Syntax.Specificity - -{- ********************************************************************* -* * -* ForAllTyFlag -* * -********************************************************************* -} - -instance Outputable ForAllTyFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary Specificity where - put_ bh SpecifiedSpec = putByte bh 0 - put_ bh InferredSpec = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return SpecifiedSpec - _ -> return InferredSpec - -instance Binary ForAllTyFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - -instance NFData Specificity where - rnf SpecifiedSpec = () - rnf InferredSpec = () -instance NFData ForAllTyFlag where - rnf (Invisible spec) = rnf spec - rnf Required = () - ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -137,7 +137,6 @@ import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName ) import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.Coercion.Axiom ( fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic @@ -425,7 +424,7 @@ mkRoleAnnotDecl loc tycon roles anns where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type - possible_roles = [(fsFromRole role, role) | role <- all_roles] + possible_roles = [(strFromRole role, role) | role <- all_roles] parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing parse_role (L loc_role (Just role)) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -14,14 +14,6 @@ types that \end{itemize} -} -{-# OPTIONS_GHC -Wno-orphans #-} -{- -Above flag is necessary for these instances: - * Binary Boxity - * Binary PromotionFlag - * Outputable Boxity - * Outputable PromotionFlag --} {-# LANGUAGE DerivingVia #-} module GHC.Types.Basic ( @@ -377,27 +369,6 @@ unSwap NotSwapped f a b = f a b unSwap IsSwapped f a b = f b a -{- ********************************************************************* -* * - Promotion flag -* * -********************************************************************* -} - -instance Outputable PromotionFlag where - ppr NotPromoted = text "NotPromoted" - ppr IsPromoted = text "IsPromoted" - -instance Binary PromotionFlag where - put_ bh NotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 - - get bh = do - n <- getByte bh - case n of - 0 -> return NotPromoted - 1 -> return IsPromoted - _ -> fail "Binary(IsPromoted): fail)" - {- ************************************************************************ * * ===================================== compiler/GHC/Types/FieldLabel.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString {- % @@ -48,7 +47,6 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Types.Name -import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Data.FastString @@ -89,12 +87,6 @@ instance Outputable FieldLabel where <> ppr (flHasDuplicateRecordFields fl) <> ppr (flHasFieldSelector fl)) -instance Outputable FieldLabelString where - ppr (FieldLabelString l) = ppr l - -instance Uniquable FieldLabelString where - getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs) - -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. data DuplicateRecordFields = DuplicateRecordFields -- ^ Fields may be duplicated in a single module ===================================== compiler/GHC/Types/Fixity.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances - -- | Fixity module GHC.Types.Fixity ( Fixity (..) @@ -11,14 +9,12 @@ module GHC.Types.Fixity , negateFixity , funTyFixity , compareFixity - , module GHC.Hs.Basic ) where import GHC.Prelude import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) ) -import GHC.Hs.Basic () -- For instances only ------------------------ ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -319,13 +319,6 @@ type instance XXHeader (GhcPass p) = DataConCantHappen deriving instance Eq (Header (GhcPass p)) -instance NFData (CType (GhcPass p)) where - rnf (CType ext mh fs) = - rnf ext `seq` rnf mh `seq` rnf fs - -instance NFData (Header (GhcPass p)) where - rnf (Header s h) = - rnf s `seq` rnf h instance NFData CCallStaticTargetUnit where rnf = \case @@ -388,14 +381,6 @@ instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where GhcTc -> x1 == x2 _ -> False -instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where - rnf = \case - DynamicTarget NoExtField -> () - StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of - GhcPs -> rnf x - GhcRn -> rnf x - GhcTc -> rnf x - instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where put_ bh = \case StaticTarget x a b -> do ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -9,16 +9,8 @@ -} {-# OPTIONS_GHC -Wno-orphans #-} -{- -Suppression of warnings are required for instances: - - Binary Activation - - Binary CompilerPhase - - Binary InlinePragma - - Binary InlineSaturation - - Binary XActivation - - Binary XInlinePragmaGhc - - Outputable CompilerPhase --} +-- Required for TTG type-family definitions, +-- There are no orphan type-class instances module GHC.Types.InlinePragma ( -- * Inline Pragma Encoding @@ -494,10 +486,6 @@ no harm. always returns 'False' when its second argument is 'NeverActive'. -} -{- TODO: These orphan instance should be moved to the GHC.Utils.{Binary,Outputable} -modules once TTG has progressed and the Language.Haskell.Syntax.Types module -no longer depends on importing GHC.Hs.Doc. --} instance Binary XInlinePragmaGhc where put_ bh (XInlinePragmaGhc s a) = do put_ bh s @@ -508,26 +496,6 @@ instance Binary XInlinePragmaGhc where a <- get bh return (XInlinePragmaGhc s a) -instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where - put_ bh (InlinePragma s a b c) = do - put_ bh a - put_ bh b - put_ bh c - case ghcPass @p of - GhcPs -> put_ bh s - GhcRn -> put_ bh s - GhcTc -> put_ bh s - - get bh = do - a <- get bh - b <- get bh - c <- get bh - s <- case ghcPass @p of - GhcPs -> get bh - GhcRn -> get bh - GhcTc -> get bh - return (InlinePragma s a b c) - instance Binary InlineSaturation where put_ bh AnySaturation = putByte bh 0 put_ bh (AppliedToAtLeast w) = putByte bh 1 *> put_ bh w @@ -620,5 +588,24 @@ pprInline' emptyInline (InlinePragma AnySaturation -> empty AppliedToAtLeast ar -> parens (text "sat-args=" <> int ar) +{- TODO: This orphan instance should be moved to GHC.Utils.Outputable once that +module can import 'GhcPass' without causing an import cycle. +@ +┌──────▶ GHC.Utils.Outputable +│ │ +│ │ Needs to access GhcPass for instance: +│ │ Outputable (InlinePragma (GhcPass p)) +│ ▼ +│ GHC.Hs.Extension.Pass +│ │ +│ │ For GenLocated, SrcSpan, unLoc +│ ▼ +│ GHC.Types.SrcLoc +│ │ +│ │ for Outputable, SDoc, +│ │ pprFastFilePath, ppr combinators +└───────────────┘ +@ +-} instance forall p. IsPass p => Outputable (InlinePragma (GhcPass p)) where ppr = pprInline ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -68,7 +68,8 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import GHC.Word ( Word64 ) import Data.Char ( chr, ord, isPrint ) -import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) {- ************************************************************************ @@ -419,6 +420,8 @@ instance Uniquable Word64 where instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm +instance Uniquable FieldLabelString where + getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs) {- ************************************************************************ ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -129,7 +129,6 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Hs.Specificity () import Language.Haskell.Syntax.Specificity import Control.DeepSeq ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DerivingVia #-} @@ -119,8 +122,13 @@ import GHC.Prelude import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name (ModuleName(..)) import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) +import Language.Haskell.Syntax.Specificity +import Language.Haskell.Syntax.Type (PromotionFlag(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.ShortText (ShortText) @@ -164,7 +172,7 @@ import qualified Data.Map.Strict as Map import Data.Proxy import Data.Set ( Set ) import qualified Data.Set as Set -import Data.Time +import Data.Time hiding ( Nominal ) import Data.List (unfoldr) import System.IO as IO import System.IO.Error ( mkIOError, eofErrorType ) @@ -1926,6 +1934,85 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + +instance Binary ForAllTyFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +instance Binary HsDocStringDecorator where + put_ bh x = case x of + HsDocStringNext -> putByte bh 0 + HsDocStringPrevious -> putByte bh 1 + HsDocStringNamed n -> putByte bh 2 >> put_ bh n + HsDocStringGroup n -> putByte bh 3 >> put_ bh n + + get bh = do + tag <- getByte bh + case tag of + 0 -> pure HsDocStringNext + 1 -> pure HsDocStringPrevious + 2 -> HsDocStringNamed <$> get bh + 3 -> HsDocStringGroup <$> get bh + t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t + +instance Binary HsDocStringChunk where + put_ bh (HsDocStringChunk bs) = put_ bh bs + get bh = HsDocStringChunk <$> get bh + +instance ( Binary (XInlinePragma p) + , Binary (Activation p) + , XXInlinePragma p ~ DataConCantHappen + ) => Binary (InlinePragma p) where + put_ bh (InlinePragma s a b c) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh s + + get bh = do + a <- get bh + b <- get bh + c <- get bh + s <- get bh + return (InlinePragma s a b c) + +instance ( Binary (XOverlapMode p) + , XXOverlapMode p ~ DataConCantHappen + ) => Binary (OverlapMode p) where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= \s -> return $ NoOverlap s + 1 -> get bh >>= \s -> return $ Overlaps s + 2 -> get bh >>= \s -> return $ Incoherent s + 3 -> get bh >>= \s -> return $ Overlapping s + 4 -> get bh >>= \s -> return $ Overlappable s + _ -> get bh >>= \s -> return $ NonCanonical s + newtype BinLocated a = BinLocated { unBinLocated :: Located a } instance Binary a => Binary (BinLocated a) where @@ -2088,6 +2175,26 @@ instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool b <- get bh pure $ if b then Boxed else Unboxed +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary FixityDirection where + put_ bh InfixL = putByte bh 0 + put_ bh InfixR = putByte bh 1 + put_ bh InfixN = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return InfixL + 1 -> return InfixR + _ -> return InfixN + instance Binary ConInfoTable where get bh = Binary.decode <$> get bh @@ -2150,3 +2257,49 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -115,12 +115,17 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.ImpExp ( NamespaceSpecifier(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import Language.Haskell.Syntax.Specificity import Language.Haskell.Syntax.Text +import Language.Haskell.Syntax.Type ( PromotionFlag(..) ) import GHC.Prelude.Basic import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) +import GHC.Utils.Encoding ( utf8DecodeByteString ) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col @@ -1108,6 +1113,28 @@ instance Outputable Extension where instance Outputable ModuleName where ppr = pprModuleName +instance Outputable FieldLabelString where + ppr (FieldLabelString l) = ppr l + +instance Outputable ForAllTyFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Outputable HsDocStringDecorator where + ppr HsDocStringNext = text "|" + ppr HsDocStringPrevious = text "^" + ppr (HsDocStringNamed n) = char '$' <> text n + ppr (HsDocStringGroup n) = text (replicate n '*') + +instance Outputable HsDocStringChunk where + ppr (HsDocStringChunk bs) = text (utf8DecodeByteString bs) + +-- | For compatibility with the existing @-ddump-parsed@ output, we only show +-- the docstring. +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where + ppr (WithHsDocIdentifiers s _ids) = ppr s + instance Outputable OsPath where ppr p = text $ either show id (decodeUtf p) @@ -2039,6 +2066,35 @@ instance Outputable TopLevelFlag where ppr TopLevel = text "<TopLevel>" ppr NotTopLevel = text "<NotTopLevel>" +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +instance Outputable Fixity where + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +instance Outputable Role where + ppr = ftext . strFromRole + instance Outputable (OverlapMode p) where ppr (NoOverlap _) = empty ppr (Overlappable _) = text "[overlappable]" @@ -2047,3 +2103,9 @@ instance Outputable (OverlapMode p) where ppr (Incoherent _) = text "[incoherent]" ppr (NonCanonical _) = text "[noncanonical]" ppr (XOverlapMode _) = text "[user TTG extension]" + +instance Outputable (NamespaceSpecifier p) where + ppr NoNamespaceSpecifier{} = empty + ppr TypeNamespaceSpecifier{} = text "type" + ppr DataNamespaceSpecifier{} = text "data" + ppr (XNamespaceSpecifier _) = text "[user TTG extension]" ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -8,6 +8,7 @@ import Data.Data (Data) import Data.Eq import Data.Ord import Data.Bool +import Data.String (IsString(..)) import Prelude {- @@ -93,6 +94,20 @@ Field Labels data Role = Nominal | Representational | Phantom deriving (Eq, Ord, Data) +instance NFData Role where + rnf Nominal = () + rnf Representational = () + rnf Phantom = () + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in GHC.Parser.PostProcess +strFromRole :: IsString s => Role -> s +strFromRole Nominal = fromString "nominal" +strFromRole Representational = fromString "representational" +strFromRole Phantom = fromString "phantom" + {- ************************************************************************ * * @@ -109,6 +124,11 @@ data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' | NoSrcStrict -- ^ no strictness annotation deriving (Eq, Data) +instance NFData SrcStrictness where + rnf SrcLazy = () + rnf SrcStrict = () + rnf NoSrcStrict = () + -- | Source Unpackedness -- -- What unpackedness the user requested @@ -117,6 +137,11 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified | NoSrcUnpack -- ^ no unpack pragma deriving (Eq, Data) +instance NFData SrcUnpackedness where + rnf SrcNoUnpack = () + rnf SrcUnpack = () + rnf NoSrcUnpack = () + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Decls/Foreign.hs ===================================== @@ -74,7 +74,7 @@ import Control.DeepSeq import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe import Data.Eq -import Prelude (Enum, Show) +import Prelude (Enum, Show, seq) {- ************************************************************************ @@ -211,6 +211,12 @@ data CCallTarget pass | DynamicTarget (XDynamicTarget pass) | XCCallTarget !(XXCCallTarget pass) +instance (NFData (XStaticTarget pass), NFData (XDynamicTarget pass), NFData (XXCCallTarget pass)) + => NFData (CCallTarget pass) where + rnf (StaticTarget x a b) = rnf a `seq` rnf b `seq` rnf x + rnf (DynamicTarget x) = rnf x + rnf (XCCallTarget x) = rnf x + data CExportSpec -- | foreign export ccall foo :: ty = CExportStatic @@ -228,6 +234,11 @@ data CType pass HText | XCType !(XXCType pass) +instance (NFData (XCType pass), NFData (Header pass), NFData (XXCType pass)) + => NFData (CType pass) where + rnf (CType ext mh fs) = rnf ext `seq` rnf mh `seq` rnf fs + rnf (XCType x) = rnf x + -- | The filename for a C header file data Header pass = Header @@ -235,6 +246,10 @@ data Header pass HText | XHeader !(XXHeader pass) +instance (NFData (XHeader pass), NFData (XXHeader pass)) => NFData (Header pass) where + rnf (Header s h) = rnf s `seq` rnf h + rnf (XHeader x) = rnf x + data Safety = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or -- switch threads, etc. So make sure things are ===================================== compiler/Language/Haskell/Syntax/Doc.hs ===================================== @@ -65,6 +65,18 @@ data HsDocString pass | XHsDocString !(XXHsDocString pass) +instance + ( NFData (XMultiLineDocString pass) + , NFData (XNestedDocString pass) + , NFData (XGeneratedDocString pass) + , NFData (XXHsDocString pass) + , NFData (LHsDocStringChunk pass) + ) => NFData (HsDocString pass) where + rnf (MultiLineDocString x a b) = rnf x `seq` rnf a `seq` rnf b + rnf (NestedDocString x a b) = rnf x `seq` rnf a `seq` rnf b + rnf (GeneratedDocString x a) = rnf x `seq` rnf a + rnf (XHsDocString x) = rnf x + mkGeneratedHsDocString :: XGeneratedDocString p -> HsDocStringChunk -> HsDocString p mkGeneratedHsDocString x = GeneratedDocString x @@ -110,3 +122,6 @@ data WithHsDocIdentifiers a pass = WithHsDocIdentifiers { hsDocString :: !a , hsDocIdentifiers :: ![LIdP pass] } + +instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where + rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i) ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -9,6 +9,7 @@ module Language.Haskell.Syntax.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax +import Control.DeepSeq import Data.Type.Equality (type (~)) import Data.Data hiding ( Fixity ) @@ -16,6 +17,7 @@ import Data.Kind (Type) import Data.Eq import Data.Ord +import Text.Show {- Note [Trees That Grow] @@ -62,6 +64,9 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension. data NoExtField = NoExtField deriving (Data,Eq,Ord) +instance NFData NoExtField where + rnf NoExtField = () + -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField @@ -95,7 +100,10 @@ can only do that if the extension field was strict (#18764). See also [DataConCantHappen and strict fields]. -} data DataConCantHappen - deriving (Data,Eq,Ord) + deriving (Data,Eq,Ord,Show) + +instance NFData DataConCantHappen where + rnf = dataConCantHappen -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a ===================================== compiler/Language/Haskell/Syntax/ImpExp.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where import Language.Haskell.Syntax.Doc (LHsDoc) @@ -6,9 +8,9 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) -import Data.Eq (Eq) +import Data.Eq (Eq(..)) import Data.Data (Data) -import Data.Bool (Bool) +import Data.Bool (Bool(..)) import Data.Maybe (Maybe) import Data.String (String) import Data.Int (Int) ===================================== compiler/Language/Haskell/Syntax/Specificity.hs ===================================== @@ -14,6 +14,7 @@ module Language.Haskell.Syntax.Specificity ( import Prelude +import Control.DeepSeq (NFData(..)) import Data.Data -- | ForAllTyFlag @@ -27,6 +28,10 @@ data ForAllTyFlag = Invisible !Specificity deriving (Eq, Ord, Data) -- (<) on ForAllTyFlag means "is less visible than" +instance NFData ForAllTyFlag where + rnf (Invisible spec) = rnf spec + rnf Required = () + -- | Whether an 'Invisible' argument may appear in source Haskell. data Specificity = InferredSpec -- ^ the argument may not appear in source Haskell, it is @@ -36,6 +41,10 @@ data Specificity = InferredSpec -- required. deriving (Eq, Ord, Data) +instance NFData Specificity where + rnf SpecifiedSpec = () + rnf InferredSpec = () + pattern Inferred, Specified :: ForAllTyFlag pattern Inferred = Invisible InferredSpec pattern Specified = Invisible SpecifiedSpec ===================================== compiler/ghc.cabal.in ===================================== @@ -566,7 +566,6 @@ Library GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat - GHC.Hs.Specificity GHC.Hs.Stats GHC.HsToCore GHC.HsToCore.Arrows ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -113,7 +113,6 @@ GHC.Hs.ImpExp GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat -GHC.Hs.Specificity GHC.Hs.Type GHC.Hs.Utils GHC.HsToCore.Breakpoints.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76401e7263b87137f8f9ef234bb9f4f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76401e7263b87137f8f9ef234bb9f4f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/TTG-No-Orphans] Resoving many TTG related orphan type-class instances
by recursion-ninja (＠recursion-ninja) 20 Jul '26

20 Jul '26

recursion-ninja pushed to branch wip/TTG-No-Orphans at Glasgow Haskell Compiler / GHC Commits: f8fb2272 by Recursion Ninja at 2026-07-20T13:29:58-04:00 Resoving many TTG related orphan type-class instances This is part a technical debt removal effort made possible now that seperating out the AST via TTG has come to a close. As the AST in 'L.H.S' has been incrementally separated from the GHC internals, there are many accumulated orphan instance of 'Binary', 'NFData', 'Outputable', and 'Uniquable'. The orphan instance of data-types from within 'L.H.S' have had thier orphan instances moved to either: 1. The module which defines the data-type 2. The module which defines the type-class; i.e. moving an orphan 'Binary' instance to 'GHC.Utils.Binary' Orphan instances resolved (37): | Data-type | Resolved instance(s) | Former orphan module(s) | | -------------------- | -------------------------- | ------------------------- | | Role | Binary, NFData, Outputable | GHC.Core.Coercion.Axiom | | SrcStrictness | Binary, NFData, Outputable | GHC.Core.DataCon | | SrcUnpackedness | Binary, NFData, Outputable | GHC.Core.DataCon | | Fixity | Binary, Outputable | GHC.Hs.Basic | | FixityDirection | Binary, Outputable | GHC.Hs.Basic | | LexicalFixity | Outputable | GHC.Hs.Basic | | CCallTarget | NFData | GHC.Hs.Decls.Foreign | | CType | NFData | GHC.Hs.Decls.Foreign | | Header | NFData | GHC.Hs.Decls.Foreign | | OverlapMode | Binary, NFData | GHC.Hs.Decls.Overlap | | WithHsDocIdentifiers | NFData, Outputable | GHC.Hs.Doc | | HsDocString | NFData | GHC.Hs.DocString | | HsDocStringChunk | Binary, Outputable | GHC.Hs.DocString | | HsDocStringDecorator | Binary, Outputable | GHC.Hs.DocString | | NamespaceSpecifier | Outputable | GHC.Hs.ImpExp | | ForAllTyFlag | Binary, NFData, Outputable | GHC.Hs.Specificity | | Specificity | Binary, NFData | GHC.Hs.Specificity | | PromotionFlag | Binary, Outputable | GHC.Types.Basic | | FieldLabelString | Outputable, Uniquable | GHC.Types.FieldLabel | | InlinePragma | Binary | GHC.Types.InlinePragma | ------------------------- Metric Decrease: hard_hole_fits ------------------------- Closes #21262, #27469 - - - - - 26 changed files: - compiler/GHC/Core/Coercion/Axiom.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/ImpExp.hs - − compiler/GHC/Hs/Specificity.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/FieldLabel.hs - compiler/GHC/Types/Fixity.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Specificity.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Core/Coercion/Axiom.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable - -- (c) The University of Glasgow 2012 -- | Module for coercion axioms, used to represent type family instances @@ -22,7 +20,7 @@ module GHC.Core.Coercion.Axiom ( coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, - Role(..), fsFromRole, + Role(..), CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn, coAxiomRuleArgRoles, coAxiomRuleRole, @@ -43,7 +41,6 @@ import GHC.Types.Name import GHC.Types.Unique import GHC.Types.Var import GHC.Utils.Misc -import GHC.Utils.Binary import GHC.Utils.Panic import GHC.Data.Pair import GHC.Types.Basic @@ -52,7 +49,6 @@ import GHC.Types.SrcLoc import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) -import Control.DeepSeq {- Note [Coercion axiom branches] @@ -521,44 +517,6 @@ instance Outputable CoAxBranch where , ppUnless (null incomps) $ text "incomps:" <+> vcat (map ppr incomps) ]) -{- -************************************************************************ -* * - Roles -* * -************************************************************************ - -Roles are defined here to avoid circular dependencies. --} - --- These names are slurped into the parser code. Changing these strings --- will change the **surface syntax** that GHC accepts! If you want to --- change only the pretty-printing, do some replumbing. See --- mkRoleAnnotDecl in GHC.Parser.PostProcess -fsFromRole :: Role -> FastString -fsFromRole Nominal = fsLit "nominal" -fsFromRole Representational = fsLit "representational" -fsFromRole Phantom = fsLit "phantom" - -instance Outputable Role where - ppr = ftext . fsFromRole - -instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) - -instance NFData Role where - rnf Nominal = () - rnf Representational = () - rnf Phantom = () - {- ************************************************************************ * * ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -5,8 +5,6 @@ \section[DataCon]{@DataCon@: Data Constructors} -} -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary - module GHC.Core.DataCon ( -- * Main data types DataCon, DataConRep(..), @@ -109,7 +107,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Data as Data import Data.Char import Data.List( find ) -import Control.DeepSeq {- Note [Data constructor representation] @@ -1030,16 +1027,6 @@ instance Outputable HsImplBang where ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b) -instance Outputable SrcStrictness where - ppr SrcLazy = char '~' - ppr SrcStrict = char '!' - ppr NoSrcStrict = empty - -instance Outputable SrcUnpackedness where - ppr SrcUnpack = text "{-# UNPACK #-}" - ppr SrcNoUnpack = text "{-# NOUNPACK #-}" - ppr NoSrcUnpack = empty - instance Outputable StrictnessMark where ppr MarkedStrict = text "!" ppr NotMarkedStrict = empty @@ -1054,40 +1041,6 @@ instance Binary StrictnessMark where 1 -> return MarkedStrict _ -> panic "Invalid binary format" -instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcLazy - 1 -> return SrcStrict - _ -> return NoSrcStrict - -instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcNoUnpack - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - -instance NFData SrcStrictness where - rnf SrcLazy = () - rnf SrcStrict = () - rnf NoSrcStrict = () - -instance NFData SrcUnpackedness where - rnf SrcNoUnpack = () - rnf SrcUnpack = () - rnf NoSrcUnpack = () - -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True ===================================== compiler/GHC/Hs/Basic.hs ===================================== @@ -1,52 +1,6 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary -{-# LANGUAGE TypeFamilies #-} - -- | Fixity module GHC.Hs.Basic ( module Language.Haskell.Syntax.Basic ) where -import GHC.Prelude - -import GHC.Utils.Outputable -import GHC.Utils.Binary - import Language.Haskell.Syntax.Basic - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - -instance Outputable Fixity where - ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] - - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - ------------------------- - -instance Binary FixityDirection where - put_ bh InfixL = - putByte bh 0 - put_ bh InfixR = - putByte bh 1 - put_ bh InfixN = - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return InfixL - 1 -> return InfixR - _ -> return InfixN ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -1,12 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- Necessary for the following instances: - * (type class): Binary OverlapMode - * (type class): NFData OverlapMode --} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- XOverlapMode, XXOverlapMode {- | Data-types describing the overlap annotations for instances as well as @@ -74,34 +69,6 @@ type instance XOverlapMode (GhcPass _) = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen -instance NFData (OverlapMode (GhcPass p)) where - rnf = \case - NoOverlap s -> rnf s - Overlappable s -> rnf s - Overlapping s -> rnf s - Overlaps s -> rnf s - Incoherent s -> rnf s - NonCanonical s -> rnf s - -instance Binary (OverlapMode (GhcPass p)) where - put_ bh = \case - NoOverlap s -> putByte bh 0 >> put_ bh s - Overlaps s -> putByte bh 1 >> put_ bh s - Incoherent s -> putByte bh 2 >> put_ bh s - Overlapping s -> putByte bh 3 >> put_ bh s - Overlappable s -> putByte bh 4 >> put_ bh s - NonCanonical s -> putByte bh 5 >> put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= \s -> return $ NoOverlap s - 1 -> get bh >>= \s -> return $ Overlaps s - 2 -> get bh >>= \s -> return $ Incoherent s - 3 -> get bh >>= \s -> return $ Overlapping s - 4 -> get bh >>= \s -> return $ Overlappable s - _ -> get bh >>= \s -> return $ NonCanonical s - pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = text "[safe]" pprSafeOverlap False = empty ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -63,16 +63,6 @@ type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass p deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass) deriving instance (Eq (LIdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where - rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i) - --- | For compatibility with the existing @-ddump-parsed' output, we only show --- the docstring. --- --- Use 'pprHsDoc' to show `HsDoc`'s internals. -instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where - ppr (WithHsDocIdentifiers s _ids) = ppr s - instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -5,6 +5,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +-- Binary HsDocString +-- Outputable HsDocString module GHC.Hs.DocString ( LHsDocString @@ -44,7 +46,6 @@ import GHC.Hs.Extension.Pass (GhcPass, GhcPs, GhcRn, GhcTc) import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension -import Control.DeepSeq import Data.Data import Data.List.NonEmpty (NonEmpty(..)) import Data.List (intercalate) @@ -82,11 +83,6 @@ instance (Show (LHsDocStringChunk pass), XXHsDocString pass ~ DataConCantHappen) instance Outputable (HsDocString (GhcPass p)) where ppr = text . renderHsDocString -instance NFData (HsDocString (GhcPass p)) where - rnf (MultiLineDocString _ a b) = rnf a `seq` rnf b - rnf (NestedDocString _ a b) = rnf a `seq` rnf b - rnf (GeneratedDocString _ a) = rnf a - -- | Annotate a pretty printed thing with its doc. -- The docstring comes after if it is 'HsDocStringPrevious'. -- Otherwise it comes before. @@ -120,37 +116,12 @@ instance Binary (HsDocString (GhcPass p)) where 2 -> GeneratedDocString noExtField <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t -instance Outputable HsDocStringDecorator where - ppr = text . printDecorator - printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" printDecorator HsDocStringPrevious = "^" printDecorator (HsDocStringNamed n) = '$':n printDecorator (HsDocStringGroup n) = replicate n '*' -instance Binary HsDocStringDecorator where - put_ bh x = case x of - HsDocStringNext -> putByte bh 0 - HsDocStringPrevious -> putByte bh 1 - HsDocStringNamed n -> putByte bh 2 >> put_ bh n - HsDocStringGroup n -> putByte bh 3 >> put_ bh n - get bh = do - tag <- getByte bh - case tag of - 0 -> pure HsDocStringNext - 1 -> pure HsDocStringPrevious - 2 -> HsDocStringNamed <$> get bh - 3 -> HsDocStringGroup <$> get bh - t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t - -instance Binary HsDocStringChunk where - put_ bh (HsDocStringChunk bs) = put_ bh bs - get bh = HsDocStringChunk <$> get bh - -instance Outputable HsDocStringChunk where - ppr = text . unpackHDSC - mkGeneratedHsDocStringGhc :: String -> HsDocString (GhcPass p) mkGeneratedHsDocStringGhc = mkGeneratedHsDocString noExtField . mkHsDocStringChunk ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -447,8 +447,3 @@ coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace filterByNamespaceSpecifierGREs :: NamespaceSpecifier (GhcPass p) -> [GlobalRdrElt] -> [GlobalRdrElt] filterByNamespaceSpecifierGREs NoNamespaceSpecifier{} = id filterByNamespaceSpecifierGREs ns_spec = filterByNamespaceGREs (coveredByNamespaceSpecifier ns_spec) - -instance Outputable (NamespaceSpecifier (GhcPass p)) where - ppr NoNamespaceSpecifier{} = empty - ppr TypeNamespaceSpecifier{} = text "type" - ppr DataNamespaceSpecifier{} = text "data" ===================================== compiler/GHC/Hs/Specificity.hs deleted ===================================== @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -module GHC.Hs.Specificity where - -import Prelude -import Control.DeepSeq (NFData(..)) - -import GHC.Utils.Outputable -import GHC.Utils.Binary - -import Language.Haskell.Syntax.Specificity - -{- ********************************************************************* -* * -* ForAllTyFlag -* * -********************************************************************* -} - -instance Outputable ForAllTyFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary Specificity where - put_ bh SpecifiedSpec = putByte bh 0 - put_ bh InferredSpec = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return SpecifiedSpec - _ -> return InferredSpec - -instance Binary ForAllTyFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - -instance NFData Specificity where - rnf SpecifiedSpec = () - rnf InferredSpec = () -instance NFData ForAllTyFlag where - rnf (Invisible spec) = rnf spec - rnf Required = () - ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -137,7 +137,6 @@ import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName ) import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.Coercion.Axiom ( fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic @@ -425,7 +424,7 @@ mkRoleAnnotDecl loc tycon roles anns where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type - possible_roles = [(fsFromRole role, role) | role <- all_roles] + possible_roles = [(strFromRole role, role) | role <- all_roles] parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing parse_role (L loc_role (Just role)) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -14,14 +14,6 @@ types that \end{itemize} -} -{-# OPTIONS_GHC -Wno-orphans #-} -{- -Above flag is necessary for these instances: - * Binary Boxity - * Binary PromotionFlag - * Outputable Boxity - * Outputable PromotionFlag --} {-# LANGUAGE DerivingVia #-} module GHC.Types.Basic ( @@ -377,27 +369,6 @@ unSwap NotSwapped f a b = f a b unSwap IsSwapped f a b = f b a -{- ********************************************************************* -* * - Promotion flag -* * -********************************************************************* -} - -instance Outputable PromotionFlag where - ppr NotPromoted = text "NotPromoted" - ppr IsPromoted = text "IsPromoted" - -instance Binary PromotionFlag where - put_ bh NotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 - - get bh = do - n <- getByte bh - case n of - 0 -> return NotPromoted - 1 -> return IsPromoted - _ -> fail "Binary(IsPromoted): fail)" - {- ************************************************************************ * * ===================================== compiler/GHC/Types/FieldLabel.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString {- % @@ -48,7 +47,6 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Types.Name -import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Data.FastString @@ -89,12 +87,6 @@ instance Outputable FieldLabel where <> ppr (flHasDuplicateRecordFields fl) <> ppr (flHasFieldSelector fl)) -instance Outputable FieldLabelString where - ppr (FieldLabelString l) = ppr l - -instance Uniquable FieldLabelString where - getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs) - -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. data DuplicateRecordFields = DuplicateRecordFields -- ^ Fields may be duplicated in a single module ===================================== compiler/GHC/Types/Fixity.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances - -- | Fixity module GHC.Types.Fixity ( Fixity (..) @@ -11,14 +9,12 @@ module GHC.Types.Fixity , negateFixity , funTyFixity , compareFixity - , module GHC.Hs.Basic ) where import GHC.Prelude import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) ) -import GHC.Hs.Basic () -- For instances only ------------------------ ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -319,13 +319,6 @@ type instance XXHeader (GhcPass p) = DataConCantHappen deriving instance Eq (Header (GhcPass p)) -instance NFData (CType (GhcPass p)) where - rnf (CType ext mh fs) = - rnf ext `seq` rnf mh `seq` rnf fs - -instance NFData (Header (GhcPass p)) where - rnf (Header s h) = - rnf s `seq` rnf h instance NFData CCallStaticTargetUnit where rnf = \case @@ -388,14 +381,6 @@ instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where GhcTc -> x1 == x2 _ -> False -instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where - rnf = \case - DynamicTarget NoExtField -> () - StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of - GhcPs -> rnf x - GhcRn -> rnf x - GhcTc -> rnf x - instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where put_ bh = \case StaticTarget x a b -> do ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -9,16 +9,8 @@ -} {-# OPTIONS_GHC -Wno-orphans #-} -{- -Suppression of warnings are required for instances: - - Binary Activation - - Binary CompilerPhase - - Binary InlinePragma - - Binary InlineSaturation - - Binary XActivation - - Binary XInlinePragmaGhc - - Outputable CompilerPhase --} +-- Required for TTG type-family definitions, +-- There are no orphan type-class instances module GHC.Types.InlinePragma ( -- * Inline Pragma Encoding @@ -494,10 +486,6 @@ no harm. always returns 'False' when its second argument is 'NeverActive'. -} -{- TODO: These orphan instance should be moved to the GHC.Utils.{Binary,Outputable} -modules once TTG has progressed and the Language.Haskell.Syntax.Types module -no longer depends on importing GHC.Hs.Doc. --} instance Binary XInlinePragmaGhc where put_ bh (XInlinePragmaGhc s a) = do put_ bh s @@ -508,26 +496,6 @@ instance Binary XInlinePragmaGhc where a <- get bh return (XInlinePragmaGhc s a) -instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where - put_ bh (InlinePragma s a b c) = do - put_ bh a - put_ bh b - put_ bh c - case ghcPass @p of - GhcPs -> put_ bh s - GhcRn -> put_ bh s - GhcTc -> put_ bh s - - get bh = do - a <- get bh - b <- get bh - c <- get bh - s <- case ghcPass @p of - GhcPs -> get bh - GhcRn -> get bh - GhcTc -> get bh - return (InlinePragma s a b c) - instance Binary InlineSaturation where put_ bh AnySaturation = putByte bh 0 put_ bh (AppliedToAtLeast w) = putByte bh 1 *> put_ bh w @@ -620,5 +588,24 @@ pprInline' emptyInline (InlinePragma AnySaturation -> empty AppliedToAtLeast ar -> parens (text "sat-args=" <> int ar) +{- TODO: This orphan instance should be moved to GHC.Utils.Outputable once that +module can import 'GhcPass' without causing an import cycle. +@ +┌──────▶ GHC.Utils.Outputable +│ │ +│ │ Needs to access GhcPass for instance: +│ │ Outputable (InlinePragma (GhcPass p)) +│ ▼ +│ GHC.Hs.Extension.Pass +│ │ +│ │ For GenLocated, SrcSpan, unLoc +│ ▼ +│ GHC.Types.SrcLoc +│ │ +│ │ for Outputable, SDoc, +│ │ pprFastFilePath, ppr combinators +└───────────────┘ +@ +-} instance forall p. IsPass p => Outputable (InlinePragma (GhcPass p)) where ppr = pprInline ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -68,7 +68,8 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import GHC.Word ( Word64 ) import Data.Char ( chr, ord, isPrint ) -import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) {- ************************************************************************ @@ -419,6 +420,8 @@ instance Uniquable Word64 where instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm +instance Uniquable FieldLabelString where + getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs) {- ************************************************************************ ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -129,7 +129,6 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Hs.Specificity () import Language.Haskell.Syntax.Specificity import Control.DeepSeq ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DerivingVia #-} @@ -119,8 +122,13 @@ import GHC.Prelude import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name (ModuleName(..)) import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) +import Language.Haskell.Syntax.Specificity +import Language.Haskell.Syntax.Type (PromotionFlag(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.ShortText (ShortText) @@ -164,7 +172,7 @@ import qualified Data.Map.Strict as Map import Data.Proxy import Data.Set ( Set ) import qualified Data.Set as Set -import Data.Time +import Data.Time hiding ( Nominal ) import Data.List (unfoldr) import System.IO as IO import System.IO.Error ( mkIOError, eofErrorType ) @@ -1926,6 +1934,85 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + +instance Binary ForAllTyFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +instance Binary HsDocStringDecorator where + put_ bh x = case x of + HsDocStringNext -> putByte bh 0 + HsDocStringPrevious -> putByte bh 1 + HsDocStringNamed n -> putByte bh 2 >> put_ bh n + HsDocStringGroup n -> putByte bh 3 >> put_ bh n + + get bh = do + tag <- getByte bh + case tag of + 0 -> pure HsDocStringNext + 1 -> pure HsDocStringPrevious + 2 -> HsDocStringNamed <$> get bh + 3 -> HsDocStringGroup <$> get bh + t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t + +instance Binary HsDocStringChunk where + put_ bh (HsDocStringChunk bs) = put_ bh bs + get bh = HsDocStringChunk <$> get bh + +instance ( Binary (XInlinePragma p) + , Binary (Activation p) + , XXInlinePragma p ~ DataConCantHappen + ) => Binary (InlinePragma p) where + put_ bh (InlinePragma s a b c) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh s + + get bh = do + a <- get bh + b <- get bh + c <- get bh + s <- get bh + return (InlinePragma s a b c) + +instance ( Binary (XOverlapMode p) + , XXOverlapMode p ~ DataConCantHappen + ) => Binary (OverlapMode p) where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= \s -> return $ NoOverlap s + 1 -> get bh >>= \s -> return $ Overlaps s + 2 -> get bh >>= \s -> return $ Incoherent s + 3 -> get bh >>= \s -> return $ Overlapping s + 4 -> get bh >>= \s -> return $ Overlappable s + _ -> get bh >>= \s -> return $ NonCanonical s + newtype BinLocated a = BinLocated { unBinLocated :: Located a } instance Binary a => Binary (BinLocated a) where @@ -2088,6 +2175,26 @@ instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool b <- get bh pure $ if b then Boxed else Unboxed +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary FixityDirection where + put_ bh InfixL = putByte bh 0 + put_ bh InfixR = putByte bh 1 + put_ bh InfixN = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return InfixL + 1 -> return InfixR + _ -> return InfixN + instance Binary ConInfoTable where get bh = Binary.decode <$> get bh @@ -2150,3 +2257,49 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -115,12 +115,17 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.ImpExp ( NamespaceSpecifier(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import Language.Haskell.Syntax.Specificity import Language.Haskell.Syntax.Text +import Language.Haskell.Syntax.Type ( PromotionFlag(..) ) import GHC.Prelude.Basic import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) +import GHC.Utils.Encoding ( utf8DecodeByteString ) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col @@ -1108,6 +1113,28 @@ instance Outputable Extension where instance Outputable ModuleName where ppr = pprModuleName +instance Outputable FieldLabelString where + ppr (FieldLabelString l) = ppr l + +instance Outputable ForAllTyFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Outputable HsDocStringDecorator where + ppr HsDocStringNext = text "|" + ppr HsDocStringPrevious = text "^" + ppr (HsDocStringNamed n) = char '$' <> text n + ppr (HsDocStringGroup n) = text (replicate n '*') + +instance Outputable HsDocStringChunk where + ppr (HsDocStringChunk bs) = text (utf8DecodeByteString bs) + +-- | For compatibility with the existing @-ddump-parsed@ output, we only show +-- the docstring. +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where + ppr (WithHsDocIdentifiers s _ids) = ppr s + instance Outputable OsPath where ppr p = text $ either show id (decodeUtf p) @@ -2039,6 +2066,35 @@ instance Outputable TopLevelFlag where ppr TopLevel = text "<TopLevel>" ppr NotTopLevel = text "<NotTopLevel>" +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +instance Outputable Fixity where + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +instance Outputable Role where + ppr = ftext . strFromRole + instance Outputable (OverlapMode p) where ppr (NoOverlap _) = empty ppr (Overlappable _) = text "[overlappable]" @@ -2047,3 +2103,9 @@ instance Outputable (OverlapMode p) where ppr (Incoherent _) = text "[incoherent]" ppr (NonCanonical _) = text "[noncanonical]" ppr (XOverlapMode _) = text "[user TTG extension]" + +instance Outputable (NamespaceSpecifier p) where + ppr NoNamespaceSpecifier{} = empty + ppr TypeNamespaceSpecifier{} = text "type" + ppr DataNamespaceSpecifier{} = text "data" + ppr (XNamespaceSpecifier _) = text "[user TTG extension]" ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -8,6 +8,7 @@ import Data.Data (Data) import Data.Eq import Data.Ord import Data.Bool +import Data.String (IsString(..)) import Prelude {- @@ -93,6 +94,20 @@ Field Labels data Role = Nominal | Representational | Phantom deriving (Eq, Ord, Data) +instance NFData Role where + rnf Nominal = () + rnf Representational = () + rnf Phantom = () + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in GHC.Parser.PostProcess +strFromRole :: IsString s => Role -> s +strFromRole Nominal = fromString "nominal" +strFromRole Representational = fromString "representational" +strFromRole Phantom = fromString "phantom" + {- ************************************************************************ * * @@ -109,6 +124,11 @@ data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' | NoSrcStrict -- ^ no strictness annotation deriving (Eq, Data) +instance NFData SrcStrictness where + rnf SrcLazy = () + rnf SrcStrict = () + rnf NoSrcStrict = () + -- | Source Unpackedness -- -- What unpackedness the user requested @@ -117,6 +137,11 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified | NoSrcUnpack -- ^ no unpack pragma deriving (Eq, Data) +instance NFData SrcUnpackedness where + rnf SrcNoUnpack = () + rnf SrcUnpack = () + rnf NoSrcUnpack = () + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Decls/Foreign.hs ===================================== @@ -74,7 +74,7 @@ import Control.DeepSeq import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe import Data.Eq -import Prelude (Enum, Show) +import Prelude (Enum, Show, seq) {- ************************************************************************ @@ -211,6 +211,12 @@ data CCallTarget pass | DynamicTarget (XDynamicTarget pass) | XCCallTarget !(XXCCallTarget pass) +instance (NFData (XStaticTarget pass), NFData (XDynamicTarget pass), NFData (XXCCallTarget pass)) + => NFData (CCallTarget pass) where + rnf (StaticTarget x a b) = rnf a `seq` rnf b `seq` rnf x + rnf (DynamicTarget x) = rnf x + rnf (XCCallTarget x) = rnf x + data CExportSpec -- | foreign export ccall foo :: ty = CExportStatic @@ -228,6 +234,11 @@ data CType pass HText | XCType !(XXCType pass) +instance (NFData (XCType pass), NFData (Header pass), NFData (XXCType pass)) + => NFData (CType pass) where + rnf (CType ext mh fs) = rnf ext `seq` rnf mh `seq` rnf fs + rnf (XCType x) = rnf x + -- | The filename for a C header file data Header pass = Header @@ -235,6 +246,10 @@ data Header pass HText | XHeader !(XXHeader pass) +instance (NFData (XHeader pass), NFData (XXHeader pass)) => NFData (Header pass) where + rnf (Header s h) = rnf s `seq` rnf h + rnf (XHeader x) = rnf x + data Safety = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or -- switch threads, etc. So make sure things are ===================================== compiler/Language/Haskell/Syntax/Doc.hs ===================================== @@ -65,6 +65,18 @@ data HsDocString pass | XHsDocString !(XXHsDocString pass) +instance + ( NFData (XMultiLineDocString pass) + , NFData (XNestedDocString pass) + , NFData (XGeneratedDocString pass) + , NFData (XXHsDocString pass) + , NFData (LHsDocStringChunk pass) + ) => NFData (HsDocString pass) where + rnf (MultiLineDocString x a b) = rnf x `seq` rnf a `seq` rnf b + rnf (NestedDocString x a b) = rnf x `seq` rnf a `seq` rnf b + rnf (GeneratedDocString x a) = rnf x `seq` rnf a + rnf (XHsDocString x) = rnf x + mkGeneratedHsDocString :: XGeneratedDocString p -> HsDocStringChunk -> HsDocString p mkGeneratedHsDocString x = GeneratedDocString x @@ -110,3 +122,6 @@ data WithHsDocIdentifiers a pass = WithHsDocIdentifiers { hsDocString :: !a , hsDocIdentifiers :: ![LIdP pass] } + +instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where + rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i) ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -9,6 +9,7 @@ module Language.Haskell.Syntax.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax +import Control.DeepSeq import Data.Type.Equality (type (~)) import Data.Data hiding ( Fixity ) @@ -16,6 +17,7 @@ import Data.Kind (Type) import Data.Eq import Data.Ord +import Text.Show {- Note [Trees That Grow] @@ -62,6 +64,9 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension. data NoExtField = NoExtField deriving (Data,Eq,Ord) +instance NFData NoExtField where + rnf NoExtField = () + -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField @@ -95,7 +100,10 @@ can only do that if the extension field was strict (#18764). See also [DataConCantHappen and strict fields]. -} data DataConCantHappen - deriving (Data,Eq,Ord) + deriving (Data,Eq,Ord,Show) + +instance NFData DataConCantHappen where + rnf = dataConCantHappen -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a ===================================== compiler/Language/Haskell/Syntax/ImpExp.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where import Language.Haskell.Syntax.Doc (LHsDoc) @@ -6,9 +8,9 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) -import Data.Eq (Eq) +import Data.Eq (Eq(..)) import Data.Data (Data) -import Data.Bool (Bool) +import Data.Bool (Bool(..)) import Data.Maybe (Maybe) import Data.String (String) import Data.Int (Int) ===================================== compiler/Language/Haskell/Syntax/Specificity.hs ===================================== @@ -14,6 +14,7 @@ module Language.Haskell.Syntax.Specificity ( import Prelude +import Control.DeepSeq (NFData(..)) import Data.Data -- | ForAllTyFlag @@ -27,6 +28,10 @@ data ForAllTyFlag = Invisible !Specificity deriving (Eq, Ord, Data) -- (<) on ForAllTyFlag means "is less visible than" +instance NFData ForAllTyFlag where + rnf (Invisible spec) = rnf spec + rnf Required = () + -- | Whether an 'Invisible' argument may appear in source Haskell. data Specificity = InferredSpec -- ^ the argument may not appear in source Haskell, it is @@ -36,6 +41,10 @@ data Specificity = InferredSpec -- required. deriving (Eq, Ord, Data) +instance NFData Specificity where + rnf SpecifiedSpec = () + rnf InferredSpec = () + pattern Inferred, Specified :: ForAllTyFlag pattern Inferred = Invisible InferredSpec pattern Specified = Invisible SpecifiedSpec ===================================== compiler/ghc.cabal.in ===================================== @@ -566,7 +566,6 @@ Library GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat - GHC.Hs.Specificity GHC.Hs.Stats GHC.HsToCore GHC.HsToCore.Arrows ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -113,7 +113,6 @@ GHC.Hs.ImpExp GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat -GHC.Hs.Specificity GHC.Hs.Type GHC.Hs.Utils GHC.HsToCore.Breakpoints.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8fb227296f3c5c5eb6b8361e82c074… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8fb227296f3c5c5eb6b8361e82c074… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/hugepages] 2 commits: rts: Implement support for 2MB hugepages
by Teo Camarasu (＠teo) 20 Jul '26

20 Jul '26

Teo Camarasu pushed to branch wip/hugepages at Glasgow Haskell Compiler / GHC Commits: c8210d78 by Teo Camarasu at 2026-07-20T18:09:44+01:00 rts: Implement support for 2MB hugepages We enable/disable it through a runtime flag (-xH). When enabled we ensure we only (de)allocate in aligned multiples of 2MB. This is only available under x86_64 Linux. It isn't available under wasm and i386. Relates to #24760 Co-authored-by: Matthew Pickering <matthewtpickering(a)gmail.com> Co-authored-by: Ben Gamari <bgamari.foss(a)gmail.com> - - - - - 76c19dd0 by Teo Camarasu at 2026-07-20T18:10:41+01:00 DROP ME: enable hugepages in default flavour - - - - - 12 changed files: - docs/users_guide/runtime_control.rst - hadrian/doc/flavours.md - hadrian/src/Flavour.hs - hadrian/src/Settings/Default.hs - rts/RtsFlags.c - rts/configure.ac - rts/include/rts/Constants.h - rts/include/rts/Flags.h - rts/posix/OSMem.c - rts/sm/OSMem.h - testsuite/tests/rts/all.T - + testsuite/tests/rts/testhugepagesmblockalloc.c Changes: ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -378,6 +378,16 @@ Miscellaneous RTS options If given, instruct the runtime linker to try to continue linking in the presence of an unresolved symbol. +.. rts-flag:: -xH + + This option enables using huge pages to back memory allocations. + Use of huge pages can make memory lookups more efficient for applications + with high memory usage. + Currently we only support 2MB hugepages on Linux. + + If huge pages aren't available to back allocations, then we fall back to + regular pages. + .. _rts-options-gc: RTS options to control the garbage collector ===================================== hadrian/doc/flavours.md ===================================== @@ -321,6 +321,10 @@ The supported transformers are listed below: <td><code>hie_files</code></td> <td>Produce hie files for stage1 libraries</td> </tr> + <tr> + <td><code>hugepages</code></td> + <td>Enable support for hugepages in the RTS.</td> + </tr> </table> ## Ways ===================================== hadrian/src/Flavour.hs ===================================== @@ -25,6 +25,7 @@ module Flavour , enableTextWithSIMDUTF , enableHieFiles , omitPragmas + , enableHugepages , completeSetting , applySettings @@ -86,6 +87,7 @@ flavourTransformers = M.fromList , "dump_stg" =: enableDumpStg , "hash_unit_ids" =: enableHashUnitIds , "hie_files" =: enableHieFiles + , "hugepages" =: enableHugepages ] where (=:) = (,) @@ -316,6 +318,14 @@ enableUBSan = builder Testsuite ? arg "--config=have_ubsan=True" ] +enableHugepages :: Flavour -> Flavour +enableHugepages = + addArgs $ + mconcat [package rts + ? builder (Cabal Setup) + ? arg "--configure-option=--enable-hugepages" + ] + -- | Use the LLVM backend in target stages viaLlvmBackend :: Flavour -> Flavour viaLlvmBackend = addArgs $ staged buildingForTarget ? builder Ghc ? arg "-fllvm" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -20,6 +20,7 @@ import qualified Hadrian.Builder.Tar import CommandLine import Expression +import Flavour import Flavour.Type import Oracles.Flag import Oracles.Setting @@ -286,7 +287,7 @@ defaultSourceArgs = SourceArgs -- | Default build flavour. Other build flavours are defined in modules -- @Settings.Flavours.*@. Users can add new build flavours in "UserSettings". defaultFlavour :: Flavour -defaultFlavour = Flavour +defaultFlavour = enableHugepages $ Flavour { name = "default" , extraArgs = defaultExtraArgs , packages = defaultPackages ===================================== rts/RtsFlags.c ===================================== @@ -182,6 +182,7 @@ void initRtsFlagsDefaults(void) RtsFlags.GcFlags.allocLimitGrace = (100*1024) / BLOCK_SIZE; RtsFlags.GcFlags.numa = false; RtsFlags.GcFlags.numaMask = 1; + RtsFlags.GcFlags.hugepages = false; RtsFlags.GcFlags.ringBell = false; RtsFlags.GcFlags.longGCSync = 0; /* detection turned off */ @@ -572,7 +573,10 @@ usage_text[] = { #endif " -xq The allocation limit given to a thread after it receives", " an AllocationLimitExceeded exception. (default: 100k)", +#if defined(HUGEPAGE_FLAGS) +" -xH Try to use hugepages to allocate memory.", "", +#endif #if defined(USE_LARGE_ADDRESS_SPACE) " -xr The size of virtual memory address space reserved by the", " two step allocator (default: 1T)", @@ -1850,11 +1854,11 @@ error = true; */ case 'q': - OPTION_UNSAFE; - RtsFlags.GcFlags.allocLimitGrace - = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX) - / BLOCK_SIZE; - break; + OPTION_UNSAFE; + RtsFlags.GcFlags.allocLimitGrace + = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX) + / BLOCK_SIZE; + break; case 'r': OPTION_UNSAFE; @@ -1862,7 +1866,16 @@ error = true; = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX); break; - default: + case 'H': + OPTION_UNSAFE; +#if defined(HUGEPAGE_FLAGS) + RtsFlags.GcFlags.hugepages = true; +#else + errorBelch("Program not compiled with hugepages support."); +#endif + break; + + default: OPTION_SAFE; errorBelch("unknown RTS option: %s",rts_argv[arg]); error = true; ===================================== rts/configure.ac ===================================== @@ -37,6 +37,17 @@ if test "$enable_asserts_all_ways" = "yes" ; then AC_DEFINE([USE_ASSERTS_ALL_WAYS], [1], [Compile-in ASSERTs in all ways.]) fi +AC_ARG_ENABLE(hugepages, +[AS_HELP_STRING([--enable-hugepages], + [Enable hugepages and set the MBlock size to 2MB.])], + [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableHugepages])], + [EnableHugepages=NO] +) +if test "$enable_hugepages" = "yes" ; then + AC_DEFINE([USE_HUGEPAGES], [1], [Enable support for hugepages and set MBlock size to 2MB.]) +fi + + # We have to run these unconditionally, but we may discard their # results in the following code AC_CANONICAL_BUILD @@ -96,7 +107,7 @@ dnl off_t, because it will affect the result of that test. AC_SYS_LARGEFILE dnl ** check for specific header (.h) files that we are interested in -AC_CHECK_HEADERS([ctype.h dlfcn.h errno.h fcntl.h limits.h locale.h nlist.h pthread.h signal.h sys/param.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timerfd.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h utime.h windows.h winsock.h sched.h]) +AC_CHECK_HEADERS([ctype.h dlfcn.h errno.h fcntl.h limits.h locale.h nlist.h pthread.h signal.h sys/param.h sys/mman.h linux/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timerfd.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h utime.h windows.h winsock.h sched.h]) dnl sys/cpuset.h needs sys/param.h to be included first on FreeBSD 9.1; #7708 AC_CHECK_HEADERS([sys/cpuset.h], [], [], ===================================== rts/include/rts/Constants.h ===================================== @@ -171,6 +171,8 @@ /* The size of a megablock (2^MBLOCK_SHIFT bytes) */ #if defined(wasm32_HOST_ARCH) #define MBLOCK_SHIFT 16 +#elif defined(USE_HUGEPAGES) +#define MBLOCK_SHIFT 21 #else #define MBLOCK_SHIFT 20 #endif ===================================== rts/include/rts/Flags.h ===================================== @@ -91,6 +91,7 @@ typedef struct _GC_FLAGS { StgWord numaMask; StgWord64 addressSpaceSize; /* large address space size in bytes */ + bool hugepages; /* Enable hugepages support */ } GC_FLAGS; /* See Note [Synchronization of flags and base APIs] */ ===================================== rts/posix/OSMem.c ===================================== @@ -73,6 +73,11 @@ # endif #endif +#if defined(HUGEPAGE_FLAGS) +static int huge_tried = 0; +static int huge_failed = 0; +#endif + static void *next_request = 0; void osMemInit(void) @@ -233,12 +238,28 @@ my_mmap (void *addr, W_ size, int operation) errorBelch("my_mmap(,,MEM_RESERVE) not supported on this platform"); # endif } else if (operation == MEM_COMMIT) { - flags = MAP_FIXED | MAP_ANON | MAP_PRIVATE; + flags = MAP_FIXED | MAP_ANONYMOUS | MAP_PRIVATE; +#if defined(HUGEPAGE_FLAGS) + if ( RtsFlags.GcFlags.hugepages && + (size & (HUGEPAGE_SIZE - 1)) == 0) { + huge_tried += 1; + flags |= HUGEPAGE_FLAGS; + } +#endif /* defined(HUGEPAGE_FLAGS) */ } else { flags = MAP_ANON | MAP_PRIVATE; } ret = mmap(addr, size, prot, flags, -1, 0); +#if defined(HUGEPAGE_FLAGS) + // If the mmap failed, and we tried with HUGEPAGE_FLAGS + // then retry without. + if (ret == MAP_FAILED && flags & HUGEPAGE_FLAGS){ + huge_failed += 1; + flags &= ~HUGEPAGE_FLAGS; + ret = mmap(addr, size, prot, flags, -1, 0); + } +#endif # if defined(linux_HOST_OS) if (ret == MAP_FAILED && errno == EPERM) { // Linux may return EPERM if it tried to give us ===================================== rts/sm/OSMem.h ===================================== @@ -8,6 +8,12 @@ #pragma once +#if defined(HAVE_LINUX_MMAN_H) && defined(USE_HUGEPAGES) +#include <linux/mman.h> +#define HUGEPAGE_FLAGS (MAP_HUGETLB | MAP_HUGE_2MB) +#define HUGEPAGE_SIZE MBLOCK_SIZE +#endif + #include "BeginPrivate.h" void osMemInit(void); ===================================== testsuite/tests/rts/all.T ===================================== @@ -15,6 +15,15 @@ test('testmblockalloc', # which will crash because the mblocks we allocate are not in a state # the leak detector is expecting. +# A variant of the above that tries to use hugepages +test('testhugepagesmblockalloc', + [c_src, only_ways(['normal','threaded1']), extra_run_opts('+RTS -I0 -xr0.125T -xH'), + unless(opsys('linux'), skip), # Huge pages are only currently supported on Linux + when(arch('wasm32'), skip), # MBlocks can't be freed on wasm32, see Note [Megablock allocator on wasm] in rts + when(arch('i386'), skip), # Not available under i386 + ], + compile_and_run, ['']) + # See bug #101, test requires +RTS -c (or equivalently +RTS -M<something>) # only GHCi triggers the bug, but we run the test all ways for completeness. ===================================== testsuite/tests/rts/testhugepagesmblockalloc.c ===================================== @@ -0,0 +1,75 @@ +#include "Rts.h" + +#include <stdio.h> + +// 16 * 64 == max 1GB +const int MAXALLOC = 16; +const int ARRSIZE = 64; + +const int LOOPS = 1000; +const int SEED = 0xf00f00; + +extern StgWord mblocks_allocated; + +int main (int argc, char *argv[]) +{ + int i, j, b; + + void *a[ARRSIZE]; + uint32_t sizes[ARRSIZE]; + + srand(SEED); + + { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + } + + // repeatedly sweep though the array, allocating new random-sized + // objects and deallocating the old ones. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + if (i > 0) + { + freeMBlocks(a[j], sizes[j]); + } + b = (rand() % MAXALLOC) + 1; + a[j] = getMBlocks(b); + sizes[j] = b; + } + } + + releaseFreeMemory(); + + for (j=0; j < ARRSIZE; j++) + { + freeMBlocks(a[j], sizes[j]); + } + + releaseFreeMemory(); + + // this time, sweep forwards allocating new blocks, and then + // backwards deallocating them. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + b = (rand() % MAXALLOC) + 1; + a[j] = getMBlocks(b); + sizes[j] = b; + } + for (j=ARRSIZE-1; j >= 0; j--) + { + freeMBlocks(a[j], sizes[j]); + } + } + + releaseFreeMemory(); + + hs_exit(); // will do a memory leak test + + exit(0); +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86a70824fa5e1ebf032e256f7bde0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86a70824fa5e1ebf032e256f7bde0d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0