[Git][ghc/ghc][wip/T27629] 22 commits: rts: fix ctoi_tuple_spill_words getting out of sync
by Simon Peyton Jones (＠simonpj) 15 Sep '26
by Simon Peyton Jones (＠simonpj) 15 Sep '26
15 Sep '26
Simon Peyton Jones pushed to branch wip/T27629 at Glasgow Haskell Compiler / GHC
Commits:
192be0b6 by Luite Stegeman at 2026-09-07T19:43:36-04:00
rts: fix ctoi_tuple_spill_words getting out of sync
Fix a few places that were not updating ctoi_tuple_spill_words
correctly, leading to corruption/crashes when dealing with large
unboxed tuples in bytecode:
- captureContinuationAndAbort
- findRetryFrameHelper/findAtomicallyFrameHelper
- interpretBCO bci_BRK_FUN
fixes #27633
- - - - -
604eb43c by Simon Jakobi at 2026-09-07T19:44:15-04:00
Hadrian: don't capture the testsuite driver's output (#27780)
a6061455d54 switched the Testsuite RunTest case from Shake's cmd to the
cmd' wrapper. cmd' always captures stdout and stderr, and since the
caller asks for Exit, it returns without dumping what it captured. As a
result the testsuite output no longer appears in CI job logs: failures,
performance metrics and the summary were lost with the job.
Use cmdExe, the uncaptured cmd, as the other plain-cmd sites in that
commit do.
Fixes #27780.
Assisted-by: Claude Fable 5.1
- - - - -
06eee015 by Luite Stegeman at 2026-09-08T06:03:06+02:00
rts: Fix missing memory barrier in eval_thunk_selector (#27477)
unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.
Fixes #27477
- - - - -
f8b2bd8f by Alan Zimmerman at 2026-09-08T09:39:12-04:00
EPA Fix HsCmdDo exact print with comments
Exact printing of HsCmdDo was ignoring the location for the do
statements, and this is an annotation that can have comments in it.
Update it so we print the statements as a unit, including any
comments.
Also add the result of auditing that we capture comments in all needed
places, noting that the remaining Anno SrcSpan instances are benign.
- - - - -
430967ab by Duncan Coutts at 2026-09-09T11:07:01+01:00
Reorder cmm decls in HeapStackCheck for a better logical grouping
And put more section headers in to deliniate the groups.
We're about to add more here, so better to organise it first.
- - - - -
344080fd by Duncan Coutts at 2026-09-09T11:07:01+01:00
Add raisePrimIOException and add it to RTS<->ghc-internal API
The raisePrimIOException is a new helper function that I/O primops will
use to help them report I/O errors. This is implemented in Haskell
(since that's a lot easier), but has a calling convention that is
easy(ish) to use from Cmm in the I/O primops.
So we add it to the RTS API struct, and since we'll use it from Cmm we
also need a field accessor macro for cmm (in deriveConstants).
See the Note about how we cannot have nice things due to async
exceptions and thunks preventing us from using catch.
- - - - -
cfdb3399 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Add new blocking functions for I/O primops
See the Note [Thread blocking for new I/O primops],
and the Note [Calling convention for raisePrimIOException].
The point is, it will allow us to report synchronous exceptions from I/O
primops, and do so much more flexibly.
Previously the I/O managers could only report async exceptions and only
nullary exceptions. This was OK historically, but no good as we add
more I/O managers and expand the range of I/O operations we support.
- - - - -
f09c09d8 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Change the encoding of results from the I/O manager to I/O primops
Previously we just had async continue or heap overflow.
We now extend what we can report with synchronous success, and
synchronous failure with an errno.
See Note [Encoding of result of I/O manager operations]
We don't use these two new cases yet, but we will. In particular an
epoll I/O manager needs to be able to report synchronous success or
failure for waitRead#/waitWrite#.
- - - - -
30f074d9 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Switch waitRead/Write# to use new blocking return frames
and update the I/O managers to set the result before resuming the
blocked threads.
This makes it possible for I/O managers to report synchronous exceptions
from the I/O primops, but that will be done in a subsequent commit.
- - - - -
a8786ced by Duncan Coutts at 2026-09-09T11:07:01+01:00
Switch Poll and Select I/O managers to report sync exceptions
rather than using raiseAsync with blockedOnBadFD_closure.
This uses the new mechanism in the blocking frame return code to report
synchronous exceptions.
- - - - -
7a9df79a by Duncan Coutts at 2026-09-09T11:07:01+01:00
Remove now-unused blockedOnBadFD
It was previously thrown by the select and poll I/O managers, but now
they use raisePrimIOException (with an EBADF errno).
- - - - -
6b0424e3 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Improve the docs for delay# waitRead# and waitWrite#
Document that the waitRead/Write# can throw exceptions (this was true
before too), and that all of them are async exception cancellation
points.
- - - - -
afeb2c30 by Duncan Coutts at 2026-09-09T20:08:58-04:00
Enable printf warnings for trace functions and fix resulting warnings
Most of the existing printf-style functions are annotated with
attributes to enable gcc/clang warnings for the printf format string,
but several trace functions in Trace.h were missing this annotation.
Enable them, and fix the resulting warnings.
- - - - -
9a442c93 by Alan Zimmerman at 2026-09-09T20:09:36-04:00
EPA: Exact print ConDeclGADT without custom enterAnn
!16321 brought in explicit capture of parens in a ConDeclGADT.
The ExactPrint update introduced a modification of the fundamental
function in exact printing, `enterAnn`, by splitting it into a version
allowing injection of functionality normally handled by the
ExactPrint class methods.
This commit refactors that code, to restore the prior `enterAnn`
version, by following the convention in ExactPrint of introducing a
helper data structure with its own `ExactPrint` instance to achieve
the same effect.
- - - - -
4e9297ea by Simon Jakobi at 2026-09-11T08:32:45-04:00
ci: Actually pass --ignore-perf-failures to the testsuite driver
684c0018d9 changed the IGNORE_PERF_FAILURES handling to append to
RUNTEST_ARGS with bash array syntax, but the three use sites still
expand RUNTEST_ARGS as a scalar, which yields only the first array
element. The appended flag was therefore dropped in every job, so
perf improvements kept failing Marge Bot batches and master pipelines,
contrary to #19562.
Append as a string instead, matching the existing --force-colors
append in test_hadrian.
Fixes #27563.
Assisted-by: Claude Fable 5.1
- - - - -
4f78dfdf by Simon Jakobi at 2026-09-11T08:33:24-04:00
testsuite: Give T26537 a 1.5x compile timeout
Its -fregs-graph compile step tends to time out in unoptimized builds
(#27188, #27776).
Assisted-by: Claude Fable 5.1
- - - - -
130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00
EPA: Remove ListBanana / ListParens from AnnListBrackets
This is a step towards making AnnList only represent
lists of items which can have either braces or layout.
- - - - -
a9827d13 by Simon Jakobi at 2026-09-11T18:53:32-04:00
Reject ~, UNPACK and multiplicity annotations on type data fields
Only `!` was rejected so far. `~`, UNPACK and multiplicity annotations
were silently accepted. None of them make sense at the type level, so
restriction (R3) of Note [Type data declarations] now covers all of
them.
Fixes #27732.
Assisted-by: Claude Fable 5.1
- - - - -
c71d5e23 by Alan Zimmerman at 2026-09-11T18:54:11-04:00
EPA: Add a Note for the exact print main loop
- - - - -
7a108e43 by Simon Jakobi at 2026-09-12T18:35:59-04:00
FastString: Drop mkFastStringWith's constructor callback
All three callers passed the same callback, a partial application of
mkNewFastStringShortByteString to the string being interned. That
partial application is allocated as a closure before the table lookup,
on the common hit path too, although the callback is needed only after
a miss.
Drop the parameter and call mkNewFastStringShortByteString directly
after a miss. Since nothing is passed "with" anymore, rename the
function to internSB.
Suggested by Simon PJ in #27528:
https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031
Assisted-by: Claude Fable 5
- - - - -
82c73b22 by Alan Zimmerman at 2026-09-12T18:36:38-04:00
EPA: More targeted HsDo exact print annotation
HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of
these are in a layout context (DoExpr, MDoExpr), others are not
(ListComp, MonadComp).
We are moving towards using AnnList only in layout contexts, so we
switch the HsDo TTG annotation from holding an AnnList for this, to
holding
Either (EpToken "[", EpToken "]") AnnList
This also allows us to trim down AnnListBrackets to only have braces
or None, thereby opening the door for unification with the existing
layout context data type EpLayout.
- - - - -
64c267e3 by Simon Peyton Jones at 2026-09-15T08:37:31+01:00
Re-introduce the "weird SpecDict" case
In this commit
commit f80375dd4945350a1d784e436975b48b9c736eaf
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Sun Jun 29 15:26:58 2025 +0100
Refactor of Specialise.hs
I removed a test for a dictionary with unbound type variables. This
turned out to be wrong; see #27629.
So this MR re-introduces it.
- - - - -
97 changed files:
- .gitlab/ci.sh
- + changelog.d/27732
- + changelog.d/T27629
- + changelog.d/fix-parallel-gc-selector-race-27477
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension/Pass.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Types.hs
- docs/users_guide/exts/type_data.rst
- hadrian/src/Builder.hs
- libraries/ghc-internal/include/RtsIfaceSymbols.h
- libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs
- rts/Capability.c
- rts/Continuation.c
- rts/HeapStackCheck.cmm
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/Interpreter.c
- rts/Messages.c
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/Printer.c
- rts/STM.c
- rts/Schedule.c
- rts/Sparks.c
- rts/StableName.c
- rts/ThreadPaused.c
- rts/Threads.c
- rts/Trace.h
- rts/include/rts/RtsToHsIface.h
- rts/include/stg/MiscClosures.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Timeout.c
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/GC.c
- rts/sm/GCUtils.c
- rts/sm/MBlock.c
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Storage.c
- rts/sm/Sweep.c
- + testsuite/tests/bytecode/T27633/Obj.hs
- + testsuite/tests/bytecode/T27633/T27633a.hs
- + testsuite/tests/bytecode/T27633/T27633a.stdout
- + testsuite/tests/bytecode/T27633/T27633b.hs
- + testsuite/tests/bytecode/T27633/T27633b.stdout
- + testsuite/tests/bytecode/T27633/all.T
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c.hs
- + testsuite/tests/ghci.debugger/scripts/T27633c.script
- + testsuite/tests/ghci.debugger/scripts/T27633c.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test20297.stdout
- + testsuite/tests/rts/T27477.hs
- + testsuite/tests/rts/T27477.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/simplCore/should_compile/Makefile
- + testsuite/tests/simplCore/should_compile/T27629.hs
- + testsuite/tests/simplCore/should_compile/T27629.stderr
- + testsuite/tests/simplCore/should_compile/T27629Plugin.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/type-data/should_fail/T27732a.hs
- + testsuite/tests/type-data/should_fail/T27732a.stderr
- + testsuite/tests/type-data/should_fail/T27732b.hs
- + testsuite/tests/type-data/should_fail/T27732b.stderr
- + testsuite/tests/type-data/should_fail/T27732c.hs
- + testsuite/tests/type-data/should_fail/T27732c.stderr
- + testsuite/tests/type-data/should_fail/T27732d.hs
- + testsuite/tests/type-data/should_fail/T27732d.stderr
- + testsuite/tests/type-data/should_fail/T27732e.hs
- + testsuite/tests/type-data/should_fail/T27732e.stderr
- + testsuite/tests/type-data/should_fail/T27732f.hs
- + testsuite/tests/type-data/should_fail/T27732f.stderr
- testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr
- testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr
- testsuite/tests/type-data/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Utils.hs
- 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/e4f13ef9707208cdbf70a4d49c5f3d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4f13ef9707208cdbf70a4d49c5f3d…
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/sjakobi/faststring-internsb-core
by Simon Jakobi (＠sjakobi) 15 Sep '26
by Simon Jakobi (＠sjakobi) 15 Sep '26
15 Sep '26
Simon Jakobi pushed new branch wip/sjakobi/faststring-internsb-core at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/faststring-internsb-c…
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
Zubin pushed to branch wip/9.14.2-rc2 at Glasgow Haskell Compiler / GHC
Commits:
53454240 by Zubin Duggal at 2026-09-15T12:09:10+05:30
Prepare 9.14.2-rc2
-------------------------
Metric Decrease:
T4029
-------------------------
- - - - -
24 changed files:
- − changelog.d/27626
- − changelog.d/27627
- − changelog.d/27703
- − changelog.d/27704
- − changelog.d/27717
- − changelog.d/T26423
- − changelog.d/T26716
- − changelog.d/T27202
- − changelog.d/T27308
- − changelog.d/T27314.md
- − changelog.d/T27360
- − changelog.d/T27440
- − changelog.d/T27455
- − changelog.d/T27583
- − changelog.d/T27586
- − changelog.d/T27639
- − changelog.d/T27657
- − changelog.d/T27705
- − changelog.d/arm_ncg_fixes_T27430
- − changelog.d/fix-parallel-gc-selector-race-27477
- − changelog.d/llvm-23
- − changelog.d/unit-index
- docs/users_guide/9.14.2-notes.rst
- libraries/base/changelog.md
Changes:
=====================================
changelog.d/27626 deleted
=====================================
@@ -1,5 +0,0 @@
-section: compiler
-synopsis: Fix a bug where an argument used only by a function's stable unfolding
- could still be marked absent, resulting in a runtime crash.
-mrs: !16503
-issues: #27626
=====================================
changelog.d/27627 deleted
=====================================
@@ -1,5 +0,0 @@
-section: compiler
-synopsis: Fix a bug where an absent constraint argument could be replaced by an
- error thunk, which GHC then evaluated, crashing the program.
-mrs: !16519
-issues: #27627
=====================================
changelog.d/27703 deleted
=====================================
@@ -1,5 +0,0 @@
-section: compiler
-synopsis: Fix a bug where the specialiser could drop an argument that the
- function's stable unfolding still used, resulting in a runtime crash.
-mrs: !16519
-issues: #27703
=====================================
changelog.d/27704 deleted
=====================================
@@ -1,6 +0,0 @@
-section: compiler
-synopsis: Fix a bug where a class declared abstractly in an hs-boot file was
- assumed not to be unary, so GHC speculatively evaluated a dictionary that
- could be bottom, crashing the program.
-mrs: !16519
-issues: #27704
=====================================
changelog.d/27717 deleted
=====================================
@@ -1,6 +0,0 @@
-section: compiler
-synopsis: Fix a bug where -fspec-eval-dictfun could speculatively evaluate a
- looping dictionary whose recursion went through an hs-boot import, hanging
- the program.
-mrs: !16519
-issues: #27717
=====================================
changelog.d/T26423 deleted
=====================================
@@ -1,15 +0,0 @@
-section: compiler
-synopsis: Introduce ``ExternalUnitDatabases`` and ``ExternalUnitDatabaseCache`` to cache unit databases.
-issues: #26423
-mrs: !16115
-
-description: {
- Cache the ``UnitDatabase`` in memory in ``ExternalUnitDatabases`` to avoid constantly reading
- the same ``UnitDatabase`` from disk with multiple home units.
-
- Allows to share the on-disk representation of ``UnitInfo`` across the whole ``UnitEnv``.
- We cache a mutable version of ``ExternalUnitDatabases`` as ``ExternalUnitDatabaseCache``
- in ``UnitEnv``.
- This allows us more easily to change the ``packageDBFlags`` and reading new package databases
- from disk if required, but cache everything that has been read from disk before.
-}
=====================================
changelog.d/T26716 deleted
=====================================
@@ -1,15 +0,0 @@
-section: rts
-synopsis: Fix design of TSO blocking info, fixing a use-after-free bug
-issues: #26716 #26717
-mrs: !15519
-description: {
- Experimental work on ASAN support for GHC (MR !15168) revealed a
- use-after-free bug when using the combination of the new poll I/O
- manager with the compacting GC. The ultimate cause is that a TSO's
- `block_info` (used by I/O managers and many other parts of the RTS)
- is sometimes a GC pointer and sometimes not, but without a consistent
- and easy-to-follow rule for when this is the case. The solution has
- been to clean up and enforce that the TSO's `why_blocked` enumeration
- is a proper tag for the `block_info`, and to use an encoding that
- determines precisely when the `block_info` is a GC pointer or not.
-}
=====================================
changelog.d/T27202 deleted
=====================================
@@ -1,13 +0,0 @@
-section: ghci
-synopsis: Fix regression to honour module targets in nested directories into GHCi after startup.
-issues: #27202 #27640
-mrs: !15980 !16591
-
-description: {
- Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup.
- GHCi wasn't honouring the `-i<directory>` argument if given via `ghci -i<directory>`.
-
- Further, we fix a bug while setting up package database stacks for GHCi that was uncovered during this fix.
- By underspecifying the version of dependencies, import modules from dependencies were ambiguous, even though
- they shouldn't have been!
-}
=====================================
changelog.d/T27308 deleted
=====================================
@@ -1,10 +0,0 @@
-section: compiler
-synopsis: Drop `preloadClosure` from `UnitState`
-issues: #27308
-mrs: !16108
-
-description: {
- Drop `preloadClosure` from `UnitState` as it is always set to the empty set.
- This allows to simplify the `UnitState` and related functions.
-}
-
=====================================
changelog.d/T27314.md deleted
=====================================
@@ -1,10 +0,0 @@
-section: compiler
-issues: #27314
-mrs: !16118
-synopsis:
- Fix spurious ``-Wincomplete-uni-patterns`` warning under ``-finfo-table-map``.
-description:
- The pattern-match checker now ignores ticks when comparing scrutinees in
- its CoreMap, so long-distance information is no longer lost across
- function-application scrutinees because debug source annotations
- (e.g. SourceNotes added by ``-finfo-table-map``) were inserted.
=====================================
changelog.d/T27360 deleted
=====================================
@@ -1,10 +0,0 @@
-section: compiler
-issues: #27360
-mrs: !16161
-synopsis:
- Recognise ``considerAccessible`` under ticks (``-g``, ``-finfo-table-map``, ``-fhpc`` etc)
-description:
- The pattern-match checker now properly recognises ``considerAccessible`` even
- when it is surrounded by ticks (e.g. debug info ticks with ``-g``, with
- ``-finfo-table-map``, etc). This ensures it works as advertised, suppressing
- redundant pattern-match warnings, even when it occurs under a tick.
=====================================
changelog.d/T27440 deleted
=====================================
@@ -1,8 +0,0 @@
-section: compiler
-issues: #27440
-mrs: !16434
-synopsis:
- Fix a panic on ``@ty`` in a pattern synonym RHS
-description:
- An invisible type argument (``@ty``) in the right-hand side of an implicitly
- bidirectional pattern synonym no longer causes a panic.
=====================================
changelog.d/T27455 deleted
=====================================
@@ -1,8 +0,0 @@
-section: base
-issues: #27455
-mrs: !16274
-synopsis:
- Don't drop `ExceptionContext` in `SomeException(toException)`
-description:
- Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`.
-
=====================================
changelog.d/T27583 deleted
=====================================
@@ -1,9 +0,0 @@
-section: compiler
-issues: #27583
-mrs: !16434
-synopsis:
- Fix spurious out-of-scope errors from ``type ty`` in a pattern synonym RHS
-description:
- A required type argument with an explicit namespace specifier (``type ty``)
- in the right-hand side of an implicitly bidirectional pattern synonym no
- longer reports variables bound by the pattern as out of scope.
=====================================
changelog.d/T27586 deleted
=====================================
@@ -1,9 +0,0 @@
-section: compiler
-issues: #27586
-mrs: !16440
-synopsis:
- Fix a panic on a required type argument in a pattern synonym RHS
-description:
- An argument of a pattern synonym that is matched against a required type
- argument in the right-hand side no longer causes a panic; it is reported as
- an illegal term-level use of a type variable.
=====================================
changelog.d/T27639 deleted
=====================================
@@ -1,10 +0,0 @@
-section: compiler
-issues: #27639
-mrs: !16474
-synopsis:
- Stop representation-polymorphism checks from producing a coercion that fails
- Core Lint.
-description:
- The representation-polymorphism check that is done when subsumption performs
- eta-expansion now composes the coercions it builds in the correct order,
- avoiding a Core Lint failure.
=====================================
changelog.d/T27657 deleted
=====================================
@@ -1,9 +0,0 @@
-section: base
-issues: #27657
-mrs: !16508
-synopsis:
- Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
-description:
- ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
- ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
- correct way to catch exceptions inside STM.
=====================================
changelog.d/T27705 deleted
=====================================
@@ -1,5 +0,0 @@
-section: compiler
-synopsis: Fixed an issue that caused the specializer to sometimes loop on recursive dictionary superclasses.
-issues: #27705
-mrs: !16559
-
=====================================
changelog.d/arm_ncg_fixes_T27430 deleted
=====================================
@@ -1,18 +0,0 @@
-section: compiler
-issues: #27430 #27539 #27538 #27537 #27550 #27565 #27533
-mrs: !16255
-synopsis:
- A series of fixes to the ARM64 ncg, related to handling of primitive
- 8/16bit types and simd.
-description:
- A series of related fixes to the ncg fixing:
-
- Fixed sign extension for subword values returned from unsafe ffi calls.
- Clarify and lint for invalid conversions of int8/int16 -> float/double conversions.
- Fix incorrect clobbering of local variables when comparing signed subword values.
- Fix incorrect use of 32bit reads/stores for 8/16bit wide reads/stores.
- Fix zero extension on function entry if arguments are passed at word-width
- but used at subword-widths.
- Fix broadcast# for non-literal arguments (arm64 only).
- Fix rare assembler errors caused by overflowing literals, by properly checking
- whether a constant is a viable immediate argument.
=====================================
changelog.d/fix-parallel-gc-selector-race-27477 deleted
=====================================
@@ -1,10 +0,0 @@
-section: rts
-synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap
-description:
- On weakly-ordered architectures such as AArch64 programs using
- could crash during parallel garbage collection (segmentation fault
- or ``internal error: eval_thunk_selector: strange selectee <n>``) or
- continue running with silently corrupted heap data, due to a missing
- memory barrier in the parallel GC.
-mrs: !16488
-issues: #27477
=====================================
changelog.d/llvm-23 deleted
=====================================
@@ -1,4 +0,0 @@
-section: llvm-backend
-synopsis: Bump LlvmMaxVersion to support LLVM 23.x releases.
-issues: #27764
-mrs: !16617
=====================================
changelog.d/unit-index deleted
=====================================
@@ -1,14 +0,0 @@
-section: compiler
-synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units
-issues: #27500 #26423 #27748
-mrs: !16115 !16598
-
-description: {
- The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s.
- This can lead to excessive memory usage with multiple home units and large package databases.
-
- Our solution to this problem is deduplicating ``UnitInfo``s globally across the whole ``UnitEnv``.
- We store this information in the ``UnitIndex`` which contains data global to all ``UnitState``s.
- All processed ``UnitInfo``s and the ``WiredMap`` are stored in there, and in the future, we might
- move more fields from ``UnitState`` to ``UnitIndex``.
-}
=====================================
docs/users_guide/9.14.2-notes.rst
=====================================
@@ -87,13 +87,30 @@ Compiler
- Make the order of usages deterministic (:ghc-ticket:`26877`)
- Fix the interaction of ExplicitLevelImports with qualified imports (:ghc-ticket:`26616`, :ghc-ticket:`27385`)
- Rename ZonkAny to UnusedType and add pretty printing logic for it (:ghc-ticket:`27390`)
+- Cache unit databases and use a global ``UnitIndex`` to deduplicate
+ ``UnitInfo``\s across multiple home units, reducing memory usage
+ (:ghc-ticket:`26423`, :ghc-ticket:`27500`, :ghc-ticket:`27748`)
+- Drop ``preloadClosure`` from ``UnitState`` (:ghc-ticket:`27308`)
+- Fix a bug where an argument used only by a function's stable unfolding could still be marked absent, resulting in a runtime crash. (:ghc-ticket:`27626`)
+- Fix a bug where an absent constraint argument could be replaced by an error thunk, which GHC then evaluated, crashing the program. (:ghc-ticket:`27627`)
+- Fix a bug where the specialiser could drop an argument that the function's stable unfolding still used, resulting in a runtime crash. (:ghc-ticket:`27703`)
+- Fix a bug where a class declared abstractly in an hs-boot file was assumed not to be unary, so GHC speculatively evaluated a dictionary that could be bottom, crashing the program. (:ghc-ticket:`27704`)
+- Fix a bug where ``-fspec-eval-dictfun`` could speculatively evaluate a looping dictionary whose recursion went through an hs-boot import, hanging the program. (:ghc-ticket:`27717`)
+- Fix a panic on ``@ty`` in a pattern synonym RHS (:ghc-ticket:`27440`)
+- Fix spurious out-of-scope errors from ``type ty`` in a pattern synonym RHS (:ghc-ticket:`27583`)
+- Fix a panic on a required type argument in a pattern synonym RHS (:ghc-ticket:`27586`)
+- Stop representation-polymorphism checks from producing a coercion that fails Core Lint. (:ghc-ticket:`27639`)
+- Fixed an issue that caused the specializer to sometimes loop on recursive dictionary superclasses. (:ghc-ticket:`27705`)
+- Bumped the maximum supported LLVM version to 23 (:ghc-ticket:`27764`)
+- Recognise ``considerAccessible`` under ticks (``-g``, ``-finfo-table-map``, ``-fhpc`` etc) (:ghc-ticket:`27360`)
+- Fix spurious ``-Wincomplete-uni-patterns`` warning under ``-finfo-table-map``. (:ghc-ticket:`27314`)
GHCi
~~~~
- Added the ``-fimport-loaded-targets`` flag, which automatically imports all loaded targets into the GHCi session (:ghc-ticket:`26866`)
- Added support for custom external interpreter commands, allowing GHC API clients to extend the external interpreter with their own message handlers (:ghc-ticket:`26652`)
-- Fix regression to allow loading modules into the GHCi after startup (:ghc-ticket:`27202`)
+- Fix regression to allow loading modules into the GHCi after startup (:ghc-ticket:`27202`, :ghc-ticket:`27640`)
- Fixed the GHCi prompt and session home units to use a consistent package database stack, avoiding spurious ambiguous-import errors for home unit dependencies (:ghc-ticket:`27202`)
- Fixed the order in which ``:info`` lists instances, which previously depended on the order in which interface files happened to be loaded (:ghc-ticket:`27532`)
@@ -128,6 +145,9 @@ Runtime System
- Fix several black hole handling bugs that could lead to deadlocks or crashes in multithreaded programs. These could show up as the program hanging or "END_TSO_QUEUE object entered" errors (:ghc-ticket:`26922`, :ghc-ticket:`26936`)
- Rethrow exceptions in overlapped IO when using the WinIO IO manager (:ghc-ticket:`27283`)
- Fix "unknown/strange object 24 crash" in compacting GC (:ghc-ticket:`27434`)
+- Fix a possible use-after-free bug with TSOs (:ghc-ticket:`26716`, :ghc-ticket:`26717`)
+- Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap (:ghc-ticket:`27477`)
+- Fix stack corruption when returning large unboxed tuples in GHCi (:ghc-ticket:`27633`)
Code Generation
~~~~~~~~~~~~~~~
@@ -139,6 +159,10 @@ Code Generation
- Fix module finalizers on multiple platforms (:ghc-ticket:`27072`)
- Fix miscompiled %load_relaxed primop, add missing %store_relaxed (:ghc-ticket:`27483`)
- Fix redundant AP thunk codegen when not using -ticky-ap-thunk (:ghc-ticket:`27502`)
+- A number of fixes to the ARM64 ncg, fixing a number of bugs, including
+ incorrect runtime results when using subword operations
+ (:ghc-ticket:`27430`, :ghc-ticket:`27539`, :ghc-ticket:`27538`,
+ :ghc-ticket:`27537`, :ghc-ticket:`27550`, :ghc-ticket:`27533`)
Bytecode Compiler
~~~~~~~~~~~~~~~~~
@@ -151,6 +175,8 @@ Bytecode Compiler
~~~~~~~~~~~~~~~~
- Added ``@since`` annotation to ``System.Info.fullCompilerVersion`` (:ghc-ticket:`26973`)
+- Don't drop ``ExceptionContext`` in ``SomeException(toException)`` (:ghc-ticket:`27455`)
+- Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler (:ghc-ticket:`27657`)
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/changelog.md
=====================================
@@ -8,6 +8,7 @@
* Hide implementation details of `throw` and `throwSTM` from exception stack traces ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387), [#26808](https://gitlab.haskell.org/ghc/ghc/-/issues/26808))
* GHC internals re-exported from `GHC.Num` have been deprecated and will be removed after one major release ([CLC proposal #360](https://github.com/haskell/core-libraries-committee/issues/360))
* The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200).
+ * Fix `retry` and async exception delivery inside a `catchSTM` handler ([#27657](https://gitlab.haskell.org/ghc/ghc/-/issues/27657))
## 4.22.0.0 *December 2025*
* Shipped with GHC 9.14.1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5345424072f8acd9c9f26fd25978f37…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5345424072f8acd9c9f26fd25978f37…
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/10.0.1-backports] 63 commits: UniqueDFM: alter should preserve insertion order
by Zubin (＠wz1000) 15 Sep '26
by Zubin (＠wz1000) 15 Sep '26
15 Sep '26
Zubin pushed to branch wip/10.0.1-backports at Glasgow Haskell Compiler / GHC
Commits:
8b72edc9 by Zubin Duggal at 2026-09-08T10:21:56+05:30
UniqueDFM: alter should preserve insertion order
Before it always inserting new elements at the end.
This is problematic because instances get inserted into the map with
`alterF`, which can change ordering of how instances are printed
with `:info` depending on the order in which we consult interfaces
I expect `alter id k = id` and `alter (fmap f) k = adjust f k`. Moving keys to
the end breaks that (`adjust` already preserves position).
Fixes #27532
(cherry picked from commit f6f2343fbbfdfd8aaed9babf5983e3e24c08ca85)
- - - - -
062e5785 by Duncan Coutts at 2026-09-08T10:21:56+05:30
Add missing updateRemembSetPushClosure in poll I/O manager
For the non-moving GC.
(cherry picked from commit daf2bd6f71b7ee309374dddf0d4793bbc0ed066d)
- - - - -
cc1eb8e3 by Duncan Coutts at 2026-09-08T10:21:56+05:30
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.
(cherry picked from commit 4d798b17c9b83f280c102ca7f96047bc0ad52df1)
- - - - -
c34ae859 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit e1cece79a6c8e53796188acd543a8b565b18a3fb)
- - - - -
cf74b881 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 795db1151237be5a3d0d2cdccb4c43309b587cdf)
- - - - -
90e5014e by Duncan Coutts at 2026-09-08T10:21:57+05:30
Remove unused tso->block_info.wakeup member
Presumably it was used once, but not now.
(cherry picked from commit 6f1c8efa1b4c78273daca99f9dda0a7e3d771330)
- - - - -
4ca77c35 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 740b88a980c4aa7f28fcf3aa89f7df8aea2813a9)
- - - - -
593b66d8 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 5b92eae2638db71ff8725295ec2a8ca254c0720b)
- - - - -
0d5049f0 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit d931715fbea83ccd402d280965a5d096a9f72949)
- - - - -
887d90b4 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 47e28ebbb4e22ad2ddb27c3f4acc5df291276743)
- - - - -
584a8405 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 96e4749d9f9b75e99d7b860325b92a5b3704e784)
- - - - -
da0c4f60 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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).
(cherry picked from commit 8f62661c133338100803347084de3566e325e64c)
- - - - -
ce670c7f by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 42c69ae2d58310c703abaa4ec933973fa9b136d3)
- - - - -
91bd23fd by Duncan Coutts at 2026-09-08T10:21:57+05:30
Use BlockInfoForceNonClosure in the select I/O manager
(cherry picked from commit 7c64632b46ac660fc0779ae96d9a05d11537b743)
- - - - -
e4d6fad6 by Duncan Coutts at 2026-09-08T10:21:57+05:30
Use BlockInfoForceNonClosure in the win32-legacy I/O manager
for the BlockedOn{Read,Write} since these use the non-heap allocated
StgAsyncIOResult.
(cherry picked from commit 8fd7104a0d63208f8408a7e5cd185bd2020225c8)
- - - - -
0a19e878 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit e0da603b8e24cfc633f29990be9ca7008f45b3c2)
- - - - -
f0365edc by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 1dd0f381ab96d3f46e113c90858870e95bd3caba)
- - - - -
b3fcb405 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 7a00ffbc311e6ee53e8b1b9181e37c3795a7b884)
- - - - -
12dd977e by Duncan Coutts at 2026-09-08T10:21:57+05:30
Remove duplicate assertion
(cherry picked from commit 522a481f5f1e51a8bdd0902012bdc467535a0382)
- - - - -
73340ce0 by Duncan Coutts at 2026-09-08T10:21:57+05:30
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.
(cherry picked from commit 0874d965ef1fec847561418857e63c067b91b0b7)
- - - - -
3d6a4321 by Duncan Coutts at 2026-09-08T10:21:57+05:30
Add a changelog entry
(cherry picked from commit 8f0bdbe138a2e1914cba7963b6931402f99c8710)
- - - - -
8e2dec3f by Cheng Shao at 2026-09-08T10:21:57+05:30
configure: bump LlvmMaxVersion to 23
This patch bumps `LlvmMaxVersion` to 23 to support LLVM 22.x releases.
(cherry picked from commit cc9cc6d5df7fb3845b1409fe708e1097896252a7)
- - - - -
b10f2f3d by Cheng Shao at 2026-09-08T10:21:57+05:30
changelog: add llvm 22.x support
(cherry picked from commit 2ea7ef8ef090fa44a0191271f644a0917908ef40)
- - - - -
41ba785d by fendor at 2026-09-08T10:21:57+05:30
Drop `preloadClosure` from `UnitState`
It is always hard-coded to the same value.
Backpack Unit instantiation isn't using it any more.
Allows us to simplify the API and get rid of `improveUnit`.
(cherry picked from commit fb5246adb7e10bd9ef07de314eaf98fbcfb729a1)
- - - - -
6508c435 by fendor at 2026-09-08T10:21:57+05:30
Introduce global unit database cache
As a first step for better sharing of `UnitInfo` across `UnitEnv`,
we introduce a new datatype called `ExternalUnitDatabases`.
It primarily serves as an in-memory representation of *all*
`UnitDatabase`s across `UnitEnv`. This means, if multiple `HomeUnitEnv`s
depend on the same database, one way or another, we make sure that we
don't parse from disk every time.
Instead, we store the in-memory representation in `ExternalUnitDatabases`.
`ExternalUnitDatabaseCache` is the equivalent of `ExternalUnitState` in
the `UnitEnv`. It is a mutable variable wrapping `ExternalUnitDatabases`.
The mutable `ExternalUnitDatabaseCache` is used in `initUnits` to make
sure we don't parse the same unit database multiple times.
Almost by accident, we change the semantics of `initUnits` to honour
modifications to `packageDBFlags`.
The inability to change `packageDBFlags` while also reusing the already
parsed `UnitDatabase`s was reported in #26423 as a bug.
Hence, we think this behaviour change is warranted and acceptable,
especially since it comes with a breaking change to the `initUnits` API.
Add regression test for #26423
Closes #26423
(cherry picked from commit 5d0ab71ac1d01c2ef19bf3146adb7dac8733dca5)
- - - - -
8efc8f46 by fendor at 2026-09-08T10:21:57+05:30
Introduce UnitIndex for global external unit caching
`UnitInfo`s have been observed to cause a lot of memory usage in #27500.
Especially with multiple home units, as the same (external) units are
processed from scratch, even though most of the time we end up with
exactly the same `UnitInfo`.
We introduce a `UnitEnv` global cache that allows us to store external
unit information that is used across all `HomeUnitEnv`s.
The most important change in this commit is the introduction of the `UnitIndex`.
It stores a global mapping of `UnitId` -> `UnitInfo`, and `initUnits`
always uses the cached `UnitInfo` entry to populate each
`HomeUnitEnv`'s `UnitState`.
This allows us to ensure the following property:
> Each `UnitInfo` should be alive exactly once in GHC.
All `UnitState`s should reference 'UnitInfo's stored in the 'UnitIndex'.
This ensured by calling 'initUnits' with the 'UnitIndex'.
In addition, the `ExternalUnitDatabases` may also hold a reference
to each on-disk representation of `UnitInfo`.
This means, we impose an hard upper bound on the number of `UnitInfo`s
alive in the GHC session:
> The number of alive `UnitInfo`s closure objects must be the
> sum of all loaded unit database times two.
We add performance regression tests that make sure the number of live
`UnitInfo` cannot exceed this threshold.
Closes #27500
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
mhu-perf
LinkableUsage02
-------------------------
These metrics increases are especially notable, as we are not even
sharing anything big but merely the global package database with 50
entries.
It shows how careful sharing of `UnitInfo` can improve memory usage.
We expect this to be much more notable when the whole cabal package
database is shared across multiple home units.
`LinkableUsage02` metric decreases on unreg and i386 platform, only.
---
Technical details
To share the `UnitInfo`s correctly, it is important that we extract
the `WireMap` into the `UnitIndex`. At the moment of writing, `WireMap`
must be globally the same for all `HomeUnitEnv`s.
This is important, as we could otherwise not cache the "fully-resolved"
`UnitInfo`, as we don't change the `UnitId` or `unitAbiHash` when
resolving wired-in units. Thus, there could be ambiguities, when the
`WireMap` is not the same for all `UnitState`s across the `UnitEnv`.
We consider a `UnitInfo` fully-resolved, if wired-in units have been
updated, the `UnitInfo` has been validated and variables in the unit
config, such as `${pkgroot}` have been resolved.
Updating the wired-in units requires the `WireMap` to be globally the
same.
(cherry picked from commit 6cce494a7ec43953c7a949e0d8ce712abfe73da7)
- - - - -
8e5b8026 by Ben Gamari at 2026-09-08T10:21:57+05:30
base: Don't drop exception context in SomeException(toException)
For reasons that are lost to time, the implementation of [CLC #200]
that was merged inappropriately dropped `ExceptionContext` in the
`toException` implementation given to `SomeException`.
Fix this infelicity.
[CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200
(cherry picked from commit 2ab02c579a9625438f5281a258051cb32ba40004)
- - - - -
fe124985 by Vladislav Zavialov at 2026-09-08T10:21:57+05:30
Discard type arguments in tcPatToExpr (#27440, #27583)
The builder expression of an implicitly bidirectional pattern synonym must not
mention types written in the RHS:
* Invisible type arguments led to a panic (#27440)
* Required type arguments failed with out-of-scope variables (#27583)
Both are now discarded, following the precedent established by pattern
signatures (#9867).
Discarding type arguments takes some care: a type pattern cannot be told from a
value pattern by syntax alone, as the `type` keyword may be omitted. Consider:
data T a b c where
MkT :: forall a. forall b c -> a -> T a b c
pattern P :: x -> T x y z
pattern P x = MkT @a (type b) c x
In P's right-hand side, `@a` and `type b` are clearly type arguments, but what
about `c` and `x`? We can only tell by matching the patterns against MkT's
type. So tcPatToExpr now runs in TcM and matches the arguments against the
constructor's TyVarBinders using zipPatsBndrs, which is made public for this
purpose. The resulting builder is $bP x = MkT _ _ x.
See Note [Discarding types in the builder expression].
Test cases: T27440a T27440b T27440c T27440d T27440e
T27583a T27583b T27583c T27583d T27583e T27583f T27583g
Metric Increase: LinkableUsage02
Metric Decrease: T27336
Assisted-by: Claude Opus 5
(cherry picked from commit 4f98510802423dcd98fa62af77997189ee97a111)
- - - - -
9c15a8f2 by sheaf at 2026-09-08T10:21:57+05:30
mkWpFun_FRR: fix ordering of coercion composition
When the subsumption machinery generates an eta-expansion, we must
perform a representation polymorphism check to ensure the lambda binder
it introduces has a fixed runtime representation.
This is done in GHC.Tc.Utils.mkWpFun_FRR.
This check involves composing quite a few coercions, arising from
representation-polymorphism checks on both the actual and expected
argument types. These coercions are then chained using HsWrapper
composition, <.>. The ordering of composition was incorrect, leading to
the Core Lint failure reported in #27639. This commit fixes that.
Fixes #27639
(cherry picked from commit eb1dcd4d98548b7bc64c323dc352ddbf149a91ec)
- - - - -
58dab25f by Bernhard M. Wiedemann at 2026-09-08T10:21:57+05:30
driver: Link object files in a deterministic order
The object files handed to the linker come from the HomePackageTable,
which is ordered by the order in which modules finished compiling. With
-j1 that is the build plan order, with -jN it is whatever the scheduler
produced, so the same sources can link to different (but equivalent)
binaries.
The order reaches the output: .text and .rodata contributions are
concatenated in link order, so e.g. building the hdav executable of the
DAV package twice, once with -j1 and once with -j4, yields two binaries
that differ in ~100kB of section contents.
Sort the home modules by module before collecting their linkables,
guarded under `Opt_ObjectDeterminism` .
Fixes #27612
Signed-off-by: Bernhard M. Wiedemann <bwiedemann(a)suse.de>
(cherry picked from commit e8d1a0d68067ba344fdff816f6b84f0117ffdc59)
- - - - -
4ea95421 by Zubin Duggal at 2026-09-08T10:21:57+05:30
hadrian: Fix links to remaining doc sites to not use the package hash for haddock links
In 07267f79d91169f474cacc8bcd38d76a6e97887d we changed hadrian to not include the package hash in the haddock
directory. This patch takes care of a few remaining links that were missed in that patch
Fixes #27671
(cherry picked from commit 1446bb039a635f2b836be19f062cbffa568fe4c5)
- - - - -
d60805ba by Vladislav Zavialov at 2026-09-08T10:21:57+05:30
Fix tcLookupId panic with RequiredTypeArguments and PatternSynonyms (#27586)
The arguments declared on the left-hand side of a pattern synonym are looked up
as term variables bound by its right-hand side. Prior to this patch, that lookup
panicked with RequiredTypeArguments:
data T a where
MkT :: forall a -> T a
pattern P :: Int -> T Int
pattern P x = MkT x
On the RHS, `x` looks like a term argument, so the renamer binds it in the term
namespace. Only during type checking does it turn out to be a type variable, so
the lookup on the LHS finds an ATyVar rather than an ATcId. As the lookup was
done with tcLookupId, it resulted in a panic.
Now the arguments are looked up with tcLookupPatSynArg, which reports an illegal
term-level use of `x`, just as an ordinary function definition `f (MkT x) = x`
does.
Test cases: T27586a T27586b T27586c
Assisted-by: Claude Opus 5
(cherry picked from commit b757727a78613e7437a713058c24b94e10697f47)
- - - - -
76771258 by Zubin Duggal at 2026-09-08T10:21:57+05:30
DmdAnal: Fix maxDmdType
We need to eta expand the smaller DmdType using defaultArgDmd, like in lubDmdType.
Introduce zipDmdType as a common combinator to implement both maxDmdType and lubDmdType
uniformly.
fixes #27626
(cherry picked from commit e31885816b7c597ad89b05da64b21c5a241bf674)
- - - - -
e7dd0389 by Andreas Klebinger at 2026-09-08T10:21:57+05:30
cmm dumps: Add machop width info with -dppr-debug for infix ops.
(cherry picked from commit e9bbe8f924ec0b9d0772cf3d4f20aa6a25f28345)
- - - - -
7fd433bd by Andreas Klebinger at 2026-09-08T10:21:57+05:30
CmmLint: Check for unsupported MachOp widths
machOpArgReps now maps MachOp + Width to a list of supported
argument widths or Nothing if the given operation is not supported
at the given width.
This allows us to check for nonsensical combinations like FloatToInt
at Word16.
Similarly we now check that every address is actually wordwidth.
(cherry picked from commit 86e3a9d8d0a85b5c80dad212cf3ec8fbf1ba72e6)
- - - - -
19fa2b3a by Andreas Klebinger at 2026-09-08T10:21:57+05:30
arm64 ncg: The big subword truncation fix.
A set of slightly related fixes to arm subword handling:
Bitmask immediates:
Don't produce overflowing assembly literals.
There is still another bug here that causes us to miss some valid
literals but we will fix that later.
Improve subword truncation handling:
We now use a small set of helpers to truncate `Register` values rather
than truncating immediate `Reg` values which greatly simplifies the code
structure. This fixes a great many bugs to do with sign/zero extending subwords
or the lack thereof.
We now establish the invariant that subword values are zero-extended at
every site at which they come into "scope" of the ncg, and rely on the
invariant throughout rather than pessimistically inserting redundant
extensions in a hodgepodge manner at the use sites of these values.
This fixes at least the bugs described in issues #27533, #27430
#27537, #27538, #27539, and #27550. But likely more bugs yet not
found.
Subword ffi results:
Apply truncations when calling functions returning
subword values.
genCondJump:
Don't sign extend signed values in the input register as
it might map to a local variable, corrupting the value stored within.
Fix subword store/load instructions.:
We used to read those at 32bit width even for smaller values possibly
resulting in invalid memory access. Now we construct the suffix for
subword variants based on the instruction format for these.
(cherry picked from commit 13781cca5c24c2671d651fd2b13a561c7386fe3a)
- - - - -
7c8e5f86 by Andreas Klebinger at 2026-09-08T10:21:57+05:30
arm64 ncg: Fix MO_V_Broadcast for non-literals.
We now use OpReg instead of OpScalarAsVec as required since we broadcast a gp register.
Also adds a test. Fixes #27565.
(cherry picked from commit d8fa5d7cc060aa7d3bee8a68b922c85b626cbe8c)
- - - - -
9e035482 by Andreas Klebinger at 2026-09-08T10:21:57+05:30
Add some test cases covering bugs in the arm ncg.
* Test for #27430 (subword ffi results)
* #27537 - subword conversions
* #27538 - subwords used in conditional
* #27533 - single byte read
(cherry picked from commit 94822c951c2a6f77c7766720e0d4ff7d4afb7290)
- - - - -
81ed35d6 by Andreas Klebinger at 2026-09-08T10:21:57+05:30
cmmLint: Lint against MO_FS_Truncate subword use.
(cherry picked from commit dd1ba88a70f47bead722e9dae8e91f9a617258aa)
- - - - -
014df595 by Rodrigo Mesquita at 2026-09-08T10:21:58+05:30
rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS
- No behavior change in this commit (well, a small optimization here
makes us do less work if the target TSO owned by the curr. capability)
- Move all THREADED_RTS CPP needed into `updThreadFlag`
- Merge MSG_SET_TSO_FLAGS and MSG_UNSET_TSO_FLAGS into MSG_UPD_TSO_FLAGS
plus a `set` bool field in the MessageUpdTSOFlag struct
Towards #27729
(cherry picked from commit bb3241717c8ee46e31fbdb3cfaed9736ba7257ea)
- - - - -
7c614470 by Rodrigo Mesquita at 2026-09-08T10:21:58+05:30
rts: Fix race condition in MSG_UPD_TSO_FLAGS execution
The code for processing the MSG_UPD_TSO_FLAGS message was not taking
into consideration that the TSO's owner might have moved in between that
capability receiving the message (since it was its previous owner) and
starting to process its inbox (a point at which it was no longer the
owner)
Added Note [TSO owner may change in between Msg being sent and received]
to explain this race and the pattern used to fix this, where we just
forward the message to the new owner.
Fixes #27729
(cherry picked from commit ed99b7b7bed699f3f2047672be7709c6d22b6df7)
- - - - -
5c2cc4ef by fendor at 2026-09-08T10:21:58+05:30
GHCi: Fix order of `PackageDBFlag`s for interactive home unit
`PackageDBFlag`s are stored in reverse order of cli specification.
When sorting the `PackageDBFlag`s by longest common prefix, we need thus
to reverse the package db stacks before calculating the prefix.
We make sure to reverse the package db stack for the interactive home
unit to uphold that later specified package dbs overwrite earlier ones.
Resolved and adds regression test for #27640
(cherry picked from commit 06fde293f2e8c80db11f4d01fcdfc482c1128db5)
- - - - -
d6f073c3 by fendor at 2026-09-08T10:21:58+05:30
Reuse the UnitIndexCache after initialising multiple home units
(cherry picked from commit 024c4d04a98f7e27b3dcb93f9b038f9b6b5a1ad9)
- - - - -
5170d064 by Andreas Klebinger at 2026-09-08T10:21:58+05:30
Specialise: Stop looping on recursive dictionaries in interestingDict
interestingDict now doesn't look through loopbreaker unfoldings.
Doing so would cause infinite loops on certain dictionaries.
Fixes #27705.
(cherry picked from commit 578bd18509f0d2aeb004231a197f7f3898f86a2a)
- - - - -
1cf16777 by Simon Peyton Jones at 2026-09-08T10:21:58+05:30
Never make an absent filler for a constraint type
mkAbsentFiller used isTerminatingType to decide, but that is not enough.
Consider
class Eq a => UC a where {}
let u :: UC Int -- UC Int is a "non-terminating type"
u = error "Absent"
let e :: Eq Int -- Eq Int is a "terminating type"
e = $p1UC u
We clearly must not make a filler for `e`, because we speculatively
evaluate it. But speculatively evaluating `e` forces `u`, so we must not
make one for `u` either.
Asking isDictTy instead is not enough either, because it does not catch a
constraint hidden behind an unreduced type family application:
type family F a :: Constraint
type instance F W = TC W
a :: F W => Int -> Int -- (F W) argument is absent
Oops! Entered absent arg Arg: irred
Type: F W
So play safe and use isPredTy: never make an absent filler for any
constraint-kinded type.
Fixes #27627
(cherry picked from commit 7bf546fc423e23cb649580016ee494efbfe144ab)
- - - - -
09bd3e50 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Add tests for absent fillers at dictionary types
T27627 a unary class whose superclass is a non-unary class
T27627a ...whose superclass is a Constraint-kinded type family
T27627b ...whose superclass is a quantified constraint
T27627c a unary class applied to itself, (UC (UC (TC a)))
T27627e a (forall b. P b) dictionary that loops
(cherry picked from commit 5f474953d1880232b5e6c5741f08746e28cd25ab)
- - - - -
18f47fdb by Zubin Duggal at 2026-09-08T10:21:58+05:30
An abstract TyCon may hide a unary class
A class declared in an hs-boot file is an AbstractTyCon inside the
module loop, and compiling the real declaration may reveal it to be a
UnaryClassTyCon.
- isTerminatingType returned True for such AbstractTyCons
- IfaceToCore set the unary flag to False in the DFunId
So we could end up speculating bottom dictionaries because inside a module
loop we see an UnaryClassTyCon as an AbstractTyCon
Use isTerminatingTyCon, which returns False for an abstract TyCon.
The Bool in DFunId is now a cache for isTerminatingTyCon, set in
mkDFunIdDetails.
Fixes #27704
(cherry picked from commit cd5c6bcc0a59c7b4dc4627fdc7471dc7938d07c2)
- - - - -
01f1c9b9 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Specialise: don't replace dead args with absent fillers
specHeader decides an argument is dead by calling isDeadBinder on a binder of
the /optimised RHS/, then applies the filler to the /stable unfolding/
template instead. The two may differ, so the argument can be dead in
the RHS and not in the template.
The specialised function's unfolding then has an absent filler, and any call
site that inlines it evaluates the error thunk.
Dropping dead args in the specialiser is rarely worth it, to quote Simon,
"The later worker/wrapper pass will pick up the dead arg later if it is really dead. Keeps the specialiser simpler."
So instead of trying to check if the arg really is dead in the stable unfolding,
just drop the logic for dropping dead args in the specialiser altogeher.
Fixes #27703
(cherry picked from commit abfc224a27cf499390efc5fe1348301fefebb910)
- - - - -
1b8c6bc7 by Zubin Duggal at 2026-09-08T10:21:58+05:30
CorePrep: don't speculate a call across an hs-boot edge
We take care not to evaluate things that might be bottom, like a
looping dictionary group, but our analysis is defeated by boot files.
We only track recursion within a module, so two dictionaries that
depend on each other across a module loop each look non-recursive, and
we might speculate them.
Any recursion we cannot see must cross an hs-boot edge, so refuse to
speculate calls that cross one.
Fixes #27717
(cherry picked from commit 1557fd1cfb802d2608cb5b138eab664564f57fb7)
- - - - -
c198530b by Cheng Shao at 2026-09-08T10:21:58+05:30
autoconf/ghc-toolchain: bump llvm upper bound to support llvm 23
This commit bumps llvm upper bound to support llvm 23.
(cherry picked from commit 56291fc550ec00784e46ec0c89ee65081090ae9f)
- - - - -
694978cc by Cheng Shao at 2026-09-08T10:21:58+05:30
rts: fix compilation issues with clang 23
clang 23 has broadened `-Wall`/`-Wextra` ranges, exposing some minor
issues in the rts when building with validate flavours:
- Unused locals
- `#pragma GCC diagnostic pop` mismatch
This commit fixes those.
(cherry picked from commit 20eb3f415f9e04a003322d1a49d95e0aaf1029f2)
- - - - -
bf050782 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump directory submodule to 1.3.11.0
- - - - -
7f5ed2ff by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump os-string submodule to 2.0.11
- - - - -
224a2e39 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump filepath submodule to 1.5.5.0
- - - - -
c9bd45bc by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump haskeline submodule to 0.8.5.0
- - - - -
42dcc16d by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump xhtml submodule to 3000.4.1.0
- - - - -
a882c355 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump Win32 submodule to 2.14.2.2
- - - - -
92154e36 by Zubin Duggal at 2026-09-08T10:21:58+05:30
Bump time submodule to 1.16.0.1
- - - - -
dd70ed87 by Simon Peyton Jones at 2026-09-15T11:17:15+05:30
Move HsStatic free-var test to typechecker
A `static` form should have no free *term* variables, but it
can have free *type* variables. Alas, the renamer does not really know what
is a term variable and what is a type variable, because of required type
arguments. This patch moves the test to the typechecker, which does know.
Addresses #27664
(cherry picked from commit c673ecf057deee858acbbaa7e6c92078a818d6f2)
- - - - -
04e6be98 by sheaf at 2026-09-15T11:18:49+05:30
Preserve tick ordering in 'tickTickedExpr'
'GHC.Core.Utils.tickTickedExpr' tries to combine a tick 't1' into an
existing stack of ticks 't2s'. There are two situations:
1. 't1' is subsumed by a tick in 't2s': drop it.
2. A tick in 't2s' is subsumed by 't1', say 't2'.
This commit ensures that in case (2) we keep 't1' on the outside instead
of replacing 't2' at its position in the stack. This avoids re-ordering
source notes (which was the cause of #27749).
This fixes a regression introduced in 2dadf3b0d05.
Fixes #27749
(cherry picked from commit e28313e31a5acfa5c5b622ef0d02acc8f3d68934)
- - - - -
174d7448 by sheaf at 2026-09-15T11:20:08+05:30
Consistently prefer local source note ticks
GHC.Cmm.DebugBlock.cmmDebugGen (DWARF annotations) and
GHC.Stg.Debug.quickSourcePos (-finfo-table-map) both contained logic to
prioritise source note ticks from the current module.
This commit commons up this logic and propagates it to a third consumer:
IPE stack frames, in GHC.Driver.GenerateCgIPEStub.
See the new function GHC.Types.Tickish.bestSourceNote.
(cherry picked from commit 3172f557f9bbd5aa01b7ca6368f8abd670a58066)
- - - - -
51fd0497 by Luite Stegeman at 2026-09-15T11:50:06+05:30
rts: fix ctoi_tuple_spill_words getting out of sync
Fix a few places that were not updating ctoi_tuple_spill_words
correctly, leading to corruption/crashes when dealing with large
unboxed tuples in bytecode:
- captureContinuationAndAbort
- findRetryFrameHelper/findAtomicallyFrameHelper
- interpretBCO bci_BRK_FUN
fixes #27633
(cherry picked from commit 192be0b6b861725613a9be5cb1587fb8cdf68bd3)
- - - - -
d4cfcd13 by Luite Stegeman at 2026-09-15T11:50:15+05:30
rts: Fix missing memory barrier in eval_thunk_selector (#27477)
unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.
Fixes #27477
(cherry picked from commit 06eee015be4e361fe9cb33e8a608ab2ea1386b52)
- - - - -
322 changed files:
- + changelog.d/27532
- + changelog.d/27626
- + changelog.d/27627
- + changelog.d/27703
- + changelog.d/27704
- + changelog.d/27717
- + changelog.d/T26423
- + changelog.d/T26716
- changelog.d/T27202
- + changelog.d/T27308
- + changelog.d/T27440
- + changelog.d/T27455
- + changelog.d/T27583
- + changelog.d/T27586
- + changelog.d/T27639
- + changelog.d/T27705
- + changelog.d/T27749
- + changelog.d/T27764
- + changelog.d/arm_ncg_fixes_T27430
- + changelog.d/fix-parallel-gc-selector-race-27477
- + changelog.d/link-deterministic-order
- + changelog.d/llvm-22
- + changelog.d/llvm-23
- + changelog.d/unit-index
- compiler/GHC.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Expr.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Unit.hs
- compiler/GHC/Unit/Env.hs
- + compiler/GHC/Unit/External/Database.hs
- + compiler/GHC/Unit/External/Index.hs
- + compiler/GHC/Unit/External/ModuleOrigin.hs
- + compiler/GHC/Unit/External/Providers.hs
- + compiler/GHC/Unit/External/Query.hs
- + compiler/GHC/Unit/External/Substitution.hs
- + compiler/GHC/Unit/External/Validate.hs
- + compiler/GHC/Unit/External/Visibility.hs
- + compiler/GHC/Unit/External/Wired.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/index.html.in
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/ghc_config.py.in
- ghc/GHCi/UI.hs
- ghc/ghc-bin.cabal.in
- hadrian/src/Rules/Generate.hs
- libraries/Win32
- libraries/base/changelog.md
- libraries/directory
- libraries/filepath
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
- libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- libraries/haskeline
- libraries/hpc
- libraries/os-string
- libraries/time
- libraries/unix
- libraries/xhtml
- rts/CloneStack.c
- rts/Continuation.c
- rts/IOManager.c
- rts/IOManager.h
- rts/Interpreter.c
- rts/Messages.c
- rts/PrimOps.cmm
- rts/ProfHeap.c
- rts/RaiseAsync.c
- rts/RaiseAsync.h
- rts/STM.c
- rts/Schedule.c
- rts/StgMiscClosures.cmm
- rts/Threads.c
- rts/Threads.h
- rts/Trace.c
- rts/Trace.h
- rts/TraverseHeap.c
- rts/eventlog/EventLog.c
- rts/include/Cmm.h
- rts/include/rts/Constants.h
- rts/include/rts/EventLogFormat.h
- rts/include/rts/storage/Closures.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- rts/posix/Poll.c
- rts/posix/Select.c
- rts/posix/Timeout.c
- rts/prim/atomic.c
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- rts/sm/Sanity.c
- rts/sm/Scav.c
- rts/win32/AsyncMIO.c
- + testsuite/tests/bytecode/T27633/Obj.hs
- + testsuite/tests/bytecode/T27633/T27633a.hs
- + testsuite/tests/bytecode/T27633/T27633a.stdout
- + testsuite/tests/bytecode/T27633/T27633b.hs
- + testsuite/tests/bytecode/T27633/T27633b.stdout
- + testsuite/tests/bytecode/T27633/all.T
- + testsuite/tests/codeGen/should_run/T27430.hs
- + testsuite/tests/codeGen/should_run/T27430.stdout
- + testsuite/tests/codeGen/should_run/T27430_c.c
- + testsuite/tests/codeGen/should_run/T27533.hs
- + testsuite/tests/codeGen/should_run/T27533.stdout
- + testsuite/tests/codeGen/should_run/T27533_cmm.cmm
- + testsuite/tests/codeGen/should_run/T27537.hs
- + testsuite/tests/codeGen/should_run/T27537.stdout
- + testsuite/tests/codeGen/should_run/T27538.hs
- + testsuite/tests/codeGen/should_run/T27538.stdout
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/core-to-stg/T27627/Callee.hs
- + testsuite/tests/core-to-stg/T27627/Caller.hs
- + testsuite/tests/core-to-stg/T27627/Main.hs
- + testsuite/tests/core-to-stg/T27627/T27627.stdout
- + testsuite/tests/core-to-stg/T27627/all.T
- + testsuite/tests/core-to-stg/T27627a/Callee.hs
- + testsuite/tests/core-to-stg/T27627a/Caller.hs
- + testsuite/tests/core-to-stg/T27627a/Main.hs
- + testsuite/tests/core-to-stg/T27627a/T27627a.stdout
- + testsuite/tests/core-to-stg/T27627a/all.T
- + testsuite/tests/core-to-stg/T27627b/Callee.hs
- + testsuite/tests/core-to-stg/T27627b/Caller.hs
- + testsuite/tests/core-to-stg/T27627b/Main.hs
- + testsuite/tests/core-to-stg/T27627b/T27627b.stdout
- + testsuite/tests/core-to-stg/T27627b/all.T
- + testsuite/tests/core-to-stg/T27627c/Callee.hs
- + testsuite/tests/core-to-stg/T27627c/Caller.hs
- + testsuite/tests/core-to-stg/T27627c/Main.hs
- + testsuite/tests/core-to-stg/T27627c/T27627c.stdout
- + testsuite/tests/core-to-stg/T27627c/all.T
- + testsuite/tests/core-to-stg/T27627e.hs
- + testsuite/tests/core-to-stg/T27627e.stdout
- + testsuite/tests/core-to-stg/T27627f/Callee.hs
- + testsuite/tests/core-to-stg/T27627f/Caller.hs
- + testsuite/tests/core-to-stg/T27627f/Inst.hs
- + testsuite/tests/core-to-stg/T27627f/Main.hs
- + testsuite/tests/core-to-stg/T27627f/T27627f.stdout
- + testsuite/tests/core-to-stg/T27627f/all.T
- + testsuite/tests/core-to-stg/T27704/Callee.hs
- + testsuite/tests/core-to-stg/T27704/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27704/Main.hs
- + testsuite/tests/core-to-stg/T27704/Mid.hs
- + testsuite/tests/core-to-stg/T27704/T27704.stdout
- + testsuite/tests/core-to-stg/T27704/all.T
- + testsuite/tests/core-to-stg/T27704a/Callee.hs
- + testsuite/tests/core-to-stg/T27704a/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27704a/Main.hs
- + testsuite/tests/core-to-stg/T27704a/Mid.hs
- + testsuite/tests/core-to-stg/T27704a/T27704a.stdout
- + testsuite/tests/core-to-stg/T27704a/all.T
- + testsuite/tests/core-to-stg/T27717/Callee.hs
- + testsuite/tests/core-to-stg/T27717/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27717/Main.hs
- + testsuite/tests/core-to-stg/T27717/Mid.hs
- + testsuite/tests/core-to-stg/T27717/T27717.stdout
- + testsuite/tests/core-to-stg/T27717/Ty.hs
- + testsuite/tests/core-to-stg/T27717/all.T
- testsuite/tests/core-to-stg/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/dmdanal/should_run/M2.hs
- + testsuite/tests/dmdanal/should_run/T27626.hs
- + testsuite/tests/dmdanal/should_run/T27626.stdout
- testsuite/tests/dmdanal/should_run/all.T
- + testsuite/tests/driver/T26423/Hello.hs
- + testsuite/tests/driver/T26423/Makefile
- + testsuite/tests/driver/T26423/T26423.hs
- + testsuite/tests/driver/T26423/T26423.stderr
- + testsuite/tests/driver/T26423/T26423.stdout
- + testsuite/tests/driver/T26423/all.T
- + testsuite/tests/driver/T26423/test/Test.hs
- + testsuite/tests/driver/T26423/test/test.pkg
- + testsuite/tests/driver/TUnitInfo/Foo.hs
- + testsuite/tests/driver/TUnitInfo/Makefile
- + testsuite/tests/driver/TUnitInfo/all.T
- + testsuite/tests/driver/TUnitInfo/genMhu.sh
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.stdout
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.stdout
- testsuite/tests/ghc-e/should_fail/T18441fail7.stderr
- testsuite/tests/ghc-e/should_run/ghc-e005.stderr
- + testsuite/tests/ghci.debugger/scripts/T27633c.hs
- + testsuite/tests/ghci.debugger/scripts/T27633c.script
- + testsuite/tests/ghci.debugger/scripts/T27633c.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/ghci/T16793/T16793.stdout
- testsuite/tests/ghci/T18060/T18060.stdout
- + testsuite/tests/ghci/T27532/Makefile
- + testsuite/tests/ghci/T27532/T27532.stdout
- + testsuite/tests/ghci/T27532/T27532j4.stdout
- + testsuite/tests/ghci/T27532/a.script
- + testsuite/tests/ghci/T27532/all.T
- + testsuite/tests/ghci/T27532/b.script
- + testsuite/tests/ghci/T27532/genT27532Modules
- + testsuite/tests/ghci/prog-mhu007/Makefile
- + testsuite/tests/ghci/prog-mhu007/a/A.hs
- + testsuite/tests/ghci/prog-mhu007/all.T
- + testsuite/tests/ghci/prog-mhu007/b/B.hs
- + testsuite/tests/ghci/prog-mhu007/prog-mhu007.script
- + testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout
- + testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs
- + testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg
- + testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs
- + testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg
- + testsuite/tests/ghci/prog-mhu007/unitA
- + testsuite/tests/ghci/prog-mhu007/unitB
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T4175.stdout
- testsuite/tests/ghci/scripts/T8469.stdout
- testsuite/tests/ghci/scripts/T8535.stdout
- testsuite/tests/ghci/scripts/T9881.stdout
- testsuite/tests/ghci/scripts/ghci020.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/ghci/should_run/T10145.stdout
- testsuite/tests/ghci/should_run/T18594.stdout
- testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
- + testsuite/tests/patsyn/should_compile/T27440a.hs
- + testsuite/tests/patsyn/should_compile/T27440b.hs
- + testsuite/tests/patsyn/should_compile/T27440c.hs
- testsuite/tests/patsyn/should_compile/all.T
- + testsuite/tests/patsyn/should_fail/T27440d.hs
- + testsuite/tests/patsyn/should_fail/T27440d.stderr
- testsuite/tests/patsyn/should_fail/all.T
- testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
- testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
- testsuite/tests/rename/should_fail/T26545.stderr
- + testsuite/tests/rep-poly/T27639.hs
- testsuite/tests/rep-poly/all.T
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/roles/should_compile/T8958.stderr
- + testsuite/tests/rts/T27477.hs
- + testsuite/tests/rts/T27477.stdout
- testsuite/tests/rts/all.T
- + testsuite/tests/simd/should_run/T27565.hs
- + testsuite/tests/simd/should_run/T27565.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simplCore/should_compile/T17966.stderr
- + testsuite/tests/simplCore/should_compile/T27749.hs
- + testsuite/tests/simplCore/should_compile/T27749.stderr
- testsuite/tests/simplCore/should_compile/T7785.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/spec004.hs
- testsuite/tests/simplCore/should_compile/spec004.stderr
- + testsuite/tests/simplCore/should_run/T27703/Lib.hs
- + testsuite/tests/simplCore/should_run/T27703/Main.hs
- + testsuite/tests/simplCore/should_run/T27703/T27703.stdout
- + testsuite/tests/simplCore/should_run/T27703/all.T
- + testsuite/tests/simplCore/should_run/T27705.hs
- + testsuite/tests/simplCore/should_run/T27705.stdout
- + testsuite/tests/simplCore/should_run/T27705_Inst.hs
- testsuite/tests/simplCore/should_run/all.T
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- + testsuite/tests/typecheck/should_compile/T27664.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T5300.stderr
- + testsuite/tests/vdq-rta/should_compile/T27583a.hs
- + testsuite/tests/vdq-rta/should_compile/T27583b.hs
- + testsuite/tests/vdq-rta/should_compile/T27583c.hs
- + testsuite/tests/vdq-rta/should_compile/T27583d.hs
- + testsuite/tests/vdq-rta/should_compile/T27583e.hs
- + testsuite/tests/vdq-rta/should_compile/T27583g.hs
- testsuite/tests/vdq-rta/should_compile/all.T
- + testsuite/tests/vdq-rta/should_fail/T27440e.hs
- + testsuite/tests/vdq-rta/should_fail/T27440e.stderr
- + testsuite/tests/vdq-rta/should_fail/T27583f.hs
- + testsuite/tests/vdq-rta/should_fail/T27583f.stderr
- + testsuite/tests/vdq-rta/should_fail/T27586a.hs
- + testsuite/tests/vdq-rta/should_fail/T27586a.stderr
- + testsuite/tests/vdq-rta/should_fail/T27586b.hs
- + testsuite/tests/vdq-rta/should_fail/T27586b.stderr
- + testsuite/tests/vdq-rta/should_fail/T27586c.hs
- + testsuite/tests/vdq-rta/should_fail/T27586c.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
- utils/haddock/haddock-api/src/Haddock.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c3add313325058ccfa841c334d2fc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c3add313325058ccfa841c334d2fc…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
d1eab429 by Andreas Klebinger at 2026-09-15T06:23:34+00:00
.hi files: Various encoding improvements
Binders: Encode non-linear binders more efficiently.
There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.
Names: Use the low rather than high bit to encode the "compactness".
Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.
This allows use to LEB128 encode the combination of tag + value efficiently.
instance Binary Integer:
We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.
Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.
instance Binary iteral:
Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.
This saves a byte per literal for small numbers.
`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.
We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:
IfaceApps IfaceExpr [IfaceExpr]
Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.
Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.
`IfaceAlt`: Improve the encoding
We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.
`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.
Generally .hi files get a few % smaller. With a relative big variance with some files
getting more then 20% smaller.
-------------------------
Metric Decrease:
if_ifacetype
-------------------------
- - - - -
14 changed files:
- + changelog.d/T27808-iface-encoding-improvements
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Utils/Binary.hs
- + testsuite/tests/utils/should_run/Binary_Literal.hs
- + testsuite/tests/utils/should_run/Binary_Literal.stdout
- testsuite/tests/utils/should_run/all.T
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
+issues: #27808
+mrs: !16683
+description: {
+ This was mostly done by moving from simple pointwise encoding to adding
+ special cases for common cases.
+}
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
+-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
+-- See Note [Iface applications] in GHC.Iface.Syntax
+mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
= -- See Note [Inlining and hs-boot files]
- IfaceApp (IfaceApp (IfaceExt noinline_id)
- (IfaceType (toIfaceType ty)))
- (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
+ IfaceApps (IfaceExt noinline_id)
+ [IfaceType (toIfaceType ty), IfaceExt name]
+ -- don't use mkIfaceApps, or infinite loop since it ends up calling
+ -- toIfaceVar indirectly again.
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -741,25 +741,38 @@ In more detail:
Tuples aren't included in the wired-in names map: see (ST1) below
* Serialisation is done by `putName`:
- - When we serialise a compact Name,
- we serialise it as a single 32-bit word:
- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
- where xxxx is the tag, and yyyy is the payload.
- The function `wiredInNamesOkay` checks that the wired-in names all have
- uniques that fit into the `yyy` field.
+ - When we serialise a compact Name, we serialise its Unique, split by
+ `unpkUniqueGrimily` into the tag character and the payload:
+
+ yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
+ \________ payload _______/\_ tag _/^ marker bit
+
+ Why are we storing the marker/tag in the low rather than high bits? Because
+ we LEB128 encode the whole word when writing to disk so we want to keep as
+ many of the high bits zero as possible to allow for shorter encodings. See
+ also wrinkle ST3.
+
+ Tags are 8 bits by construction, and there is a check that the actual unique
+ part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
+ known-key names.
- When we serialise a non-compact name:
- We look it up in the (stateful, growing) symbol table
- - If it not there we add it to the symbol table
- - We serialise the occurrenc to a single 32-bit word:
- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
- where `xxxxx` is an index into the symbol table.
+ - If it is not there we add it to the symbol table
+ - We serialise the occurrence as
-* Deserialision is done by `getName`. We read a 32-bit word
- - If the MSB is `10` it must be a compact name, so we use
+ 0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
+
+ In other words we simply shift the index by a bit.
+ The high bit is currently unused. But `putSymtabNameRef`
+ asserts that `ix` fits in 30 bits.
+
+* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
+ of the word it reads:
+ - If it is 1 it must be a compact name, so we reassemble the Unique and use
`lookupCompactName` to get from the Unique to the Name.
- - If the MSB is `00` it must be a non-compact Name,
- so we look it up in the symbol table.
+ - If it is 0 it must be a non-compact Name, so we look it up in the
+ symbol table.
Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
`isCompactName` that tests for `knownUniqueTupleName` and then the
TyConRepNames would be serialised as non-compact names, and everything would
work. Fewer tests, but Typeable-heavy code might have bigger interface files.
+
+(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
+ disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
+ This has consequences as it means we want to keep the high bits zero where possible
+ to allow for a shorter ULEB128 encoding.
+
+ This is why we put both the tag and the marker bit at the LSB end of the word. They
+ are always present. But by putting them at the low end we ensure LEB128 encoding
+ still works as expected, producing smaller encodings for compact names with small
+ uniques.
+
+ The downside is that we steal one bit from non-compact names for which the marker
+ bit and tag would have been zero either way. But in practice this matters far less
+ than ensuring built in (compact) names encode well.
-}
isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
where
(tag, ix) = unpkUniqueGrimily u
+-- | Write a reference to a symbol table index.
+-- See Note [Symbol table representation of names]
+putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
+{-# INLINE putSymtabNameRef #-}
+putSymtabNameRef bh ix
+ = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
+ (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
+ -- Bit 0 == False marks a symbol table reference
+ put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
+
+-- | Write a reference to a compact (known-key) 'Name'.
+-- See Note [Symbol table representation of names]
+putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
+{-# INLINE putCompactNameRef #-}
+putCompactNameRef bh uniq
+ = -- INVARIANTS:
+ -- * 8 bits tag (true by construction)
+ -- * the payload fits in 22 bits (checked for all known keys elsewhere)
+ -- Bit 0 == True marks a compact (known-key) name
+ put_ bh ( (fromIntegral payload `shiftL` 9)
+ .|. (fromIntegral (ord tag) `shiftL` 1)
+ .|. 1 :: Word32)
+ where
+ (tag, payload) = unpkUniqueGrimily uniq
+
-- See Note [Symbol table representation of names]
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isCompactName name
- , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
+ = putCompactNameRef bh (nameUnique name)
| otherwise
= do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putSymtabNameRef bh off
Nothing -> do
off <- freshIndex
let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
- put_ bh (fromIntegral off :: Word32)
+ putSymtabNameRef bh off
where
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral i
- 0x80000000 -> return $! lookupCompactName u
- where
- tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- u = mkUniqueGrimilyWithTag tag ix
-
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+ if i .&. 1 == 0
+ then -- Symbol table reference, written by putSymtabNameRef
+ return $! symtab ! fromIntegral (i `shiftR` 1)
+ else -- Compact name, written by putCompactNameRef
+ let tag = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
+ payload = fromIntegral (i `shiftR` 9) :: Word64
+ in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
= IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
= IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceApps fun args)
+ = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
rnIfaceExpr (IfaceCase scrut case_bndr alts)
= IfaceCase <$> rnIfaceExpr scrut
<*> pure case_bndr
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
+ IfaceExpr(..), mkIfaceApp,
+ IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- zipWithEqual )
+import GHC.Utils.Misc( dropList, filterByList, notNull,
+ unzipWith, zipWithEqual )
import GHC.Data.FastString
import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceLamBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
+ -- ^ Application to exactly one argument.
+ -- See Note [Iface applications]
+ | IfaceApps IfaceExpr [IfaceExpr]
+ -- ^ Application to two or more arguments.
+ -- See Note [Iface applications]
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+-- | Apply an expression to a (possibly empty) list of arguments, maintaining
+-- the invariants of 'IfaceApp' and 'IfaceApps'.
+-- See Note [Iface applications].
+mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
+mkIfaceApp fun args = go fun args
+ where
+ go (IfaceApp f a) as = go f (a : as)
+ go (IfaceApps f fs) as = go f (fs ++ as)
+
+ go f [] = f
+ go f [a] = IfaceApp f a
+ go f as = IfaceApps f as
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
{-
+Note [Iface applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A Core application chain (f a1 a2 ... an) could be represented by a chain of
+n nested IfaceApp nodes like Core does. However this is generally a worse
+representation for *serialization* which is the main purpose of the Iface type.
+
+So we keep the single argument constructor as it's fairly common, and add one
+to represent multiple arguments:
+
+ * IfaceApp f a -- exactly one argument
+ * IfaceApps f [a1,..] -- two or more arguments
+
+with two invariants:
+
+ (1) The argument list of an IfaceApps has at least two elements.
+ (A one-argument application is an IfaceApp, and a zero-argument
+ "application" is just the head itself.)
+
+ (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
+ IfaceApps: application chains are fully flattened.
+
+The smart constructor 'mkIfaceApp' establishes both invariants; producers
+should use it rather than building IfaceApps directly.
+
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
<> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
<> parens (ppr r)
-pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
+-- that --show-iface output does not depend on which one the producer emitted.
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
nest 2 (pprParendIfaceExpr arg) : args
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApps fun as) args = pprIfaceApp fun $
+ map (nest 2 . pprParendIfaceExpr) as ++ args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceApps f as) = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
{-# INLINE (.<<|.) #-}
+-- Encoding shortcuts:
+-- Since only IfaceDataAlt can have binders
+-- we can skip the binder list for DEFAULT and Literal alternatives.
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
- put_ bh b
+ case a of
+ IfaceDataAlt {} -> put_ bh b
+ _ -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
put_ bh c
get bh = do
a <- get bh
- b <- get bh
+ b <- case a of
+ IfaceDataAlt {} -> get bh
+ _ -> return []
c <- get bh
return (IfaceAlt a b c)
+{- Note [IfaceExpr encoding shortcuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use a full byte to encode the constructor tag for `IfaceExpr`.
+This leaves room to encode additional information. Concretely we
+use:
+
+0 .. 14: "Simple" constructor tags.
+15 .. 22: "IfaceApps", encoding the constructor *and* arity.
+ 23: "IfaceCase" for a case with a single default alternative.
+
+Note [Binary encoding of IfaceApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For IfaceApps we use the following scheme:
+
+ * arity 2..8: one byte encoding the arity as (15 + (n-2))
+ Which is followed by the head expression and then exactly `arity` arguments.
+
+ * arity > 8: tag 22, and we serialize the argument count as a ULEB128, followed by the
+ head expression and arguments.
+
+This saves us one byte per application with `2 <= arity <= 8`.
+-}
instance Binary IfaceExpr where
put_ bh (IfaceLcl aa) = do
putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
putByte bh 5
put_ bh ag
put_ bh ah
+ -- See Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
+ putByte bh 23
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
put_ bh (IfaceCase ai aj ak) = do
putByte bh 6
put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
putByte bh 14
put_ bh r
put_ bh torc
+ -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
+ -- and Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceApps fun args) = do
+ let !n = length args
+ massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
+ if n <= maxIfaceAppsTagArity
+ then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
+ else do putByte bh (fromIntegral ifaceAppsBigTag)
+ put_ bh n
+ put_ bh fun
+ mapM_ (put_ bh) args
get bh = do
h <- getByte bh
case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
14 -> do r <- get bh
torc <- get bh
return (IfaceLitRubbish torc r)
+ -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
+ -- tag 22 is followed by an explicit (LEB128) argument count.
+ -- See Note [Binary encoding of IfaceApps]
+ 15 -> getApps 2
+ 16 -> getApps 3
+ 17 -> getApps 4
+ 18 -> getApps 5
+ 19 -> getApps 6
+ 20 -> getApps 7
+ 21 -> getApps 8
+ 22 -> do n <- get bh
+ getApps n
+ -- case scrut of bndr { DEFAULT -> rhs}
+ 23 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
_ -> panic ("get IfaceExpr " ++ show h)
+ where
+ getApps :: Int -> IO IfaceExpr
+ getApps n = do fun <- get bh
+ args <- replicateM n (get bh)
+ return (IfaceApps fun args)
+-- | Tag used for an 'IfaceApps' with exactly two arguments and start
+-- of the ifaceApps tag range.
+ifaceAppsTag0 :: Int
+ifaceAppsTag0 = 15
+
+-- | Highest arity encoded directly in tag byte.
+maxIfaceAppsTagArity :: Int
+maxIfaceAppsTagArity = 8
+
+-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
+ifaceAppsBigTag :: Int
+ifaceAppsBigTag = 22
instance Binary IfaceTickish where
put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
+ IfaceApps e es -> rnf e `seq` rnf es
IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
where
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
+-- | IfaceBndr shortcuts:
+--
+-- In the vast majority of cases binder multiplicity is `Many` so storing it is
+-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
+-- (Name,Ty) in the common case where multiplicity == Many.
instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr (mult, name, ty))
+ -- The implicit Many shortcut.
+ | mult == many_ty = do
+ putByte bh 2
+ put_ bh name
+ put_ bh ty
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
- _ -> do ab <- get bh
+ 1 -> do ab <- get bh
return (IfaceTvBndr ab)
+ _ -> do name <- get bh
+ ty <- get bh
+ return (IfaceIdBndr (many_ty, name, ty))
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot =
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceApps f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+tcIfaceExpr (IfaceApps fun args)
+ = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
+
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -167,7 +167,7 @@ data LitNumType
| LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
| LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
- deriving (Data,Enum,Eq,Ord)
+ deriving (Data,Enum,Eq,Ord,Bounded)
-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
-}
+{-
+Note [Binary Literal encoding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than write `LitNumType` into it's own tag byte we encode it in the
+surplus space of the `Literal` tag space.
+
+This means for `Literal` tag 0 .. 5 are the non-num literals.
+Literals 6 .. (maxBound LitNumType) encode the LitNumType.
+
+We could use the `LitNumType` information to slightly improve the encoding of
+the actual values too. But we just write/read them at Integer for simplicity for
+now.
+-}
+
+-- | The 'Binary' tag byte of @'LitNumber' nt _@.
+--
+-- These continue the tags of the non-numeric 'Literal' constructors. The
+-- mapping is total and part of the interface file format.
+-- See Note [Binary Literal encoding].
+litNumTypeTag :: LitNumType -> Word8
+litNumTypeTag nt =
+ -- 6 .. 16
+ 6 + (fromIntegral $ fromEnum nt)
+
+-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
+-- of a numeric literal. See Note [Binary Literal encoding].
+litNumTypeOfTag :: Word8 -> Maybe LitNumType
+litNumTypeOfTag tag
+ | tag >= 6 && tag <= 16
+ = Just (toEnum $ (fromIntegral tag) - 6)
+ | otherwise = Nothing
+
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
= do putByte bh 5
put_ bh aj
put_ bh fod
+ -- The LitNumType is part of the tag byte.
+ -- See Note [Binary Literal encoding]
put_ bh (LitNumber nt i)
- = do putByte bh 6
- put_ bh nt
+ = do putByte bh (litNumTypeTag nt)
put_ bh i
put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
-- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
aj <- get bh
fod <- get bh
return (LitLabel aj fod)
- 6 -> do
- nt <- get bh
- i <- get bh
- return (LitNumber nt i)
- _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+ _ | Just nt <- litNumTypeOfTag h
+ -> do i <- get bh
+ return (LitNumber nt i)
+ | otherwise
+ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance NFData Literal where
rnf (LitChar c) = rnf c
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
case unpkUniqueGrimily u of
- (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+ (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -148,7 +148,7 @@ import GHCi.FFI
import GHCi.Message
import Control.DeepSeq
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Control.Monad ( when, unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time hiding ( Nominal )
-import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import Type.Reflection ( Typeable, SomeTypeRep(..) )
@@ -181,6 +180,8 @@ import Type.Reflection.Unsafe
import qualified Type.Reflection as Refl
import GHC.Real ( Ratio(..) )
import GHC.Float
+import GHC.Num.Integer ( Integer(IS) )
+
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import GHC.ByteOrder
@@ -805,6 +806,7 @@ getULEB128 bh =
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
@@ -1123,86 +1125,91 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
-
-We used to encode values in the Int32 range as such,
-falling back to a string of all things. In either case
-we stored a tag byte to discriminate between the two cases.
-
-This made some sense as it's highly portable but also not very
-efficient.
-
-However GHC stores a surprisingly large number of large Integer
-values. In the examples looked at between 25% and 50% of Integers
-serialized were outside of the Int32 range.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-Consider a value like `2724268014499746065`, some sort of hash
-actually generated by GHC.
-In the old scheme this was encoded as a list of 19 chars. This
-gave a size of 77 Bytes, one for the length of the list and 76
-since we encode chars as Word32 as well.
+This is a tradeoff:
+It allows shorter encodings for the common case of small values. And we don't need
+to prefix the string with a byte carrying any information about size or sign.
-We can easily do better. The new plan is:
+However it means large Integer values will pay some overhead. Their encoding can
+go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
+into a `Integer` accumulator rather than a simple Word64#.
-* Start with a tag byte
- * 0 => Int64 (LEB128 encoded)
- * 1 => Negative large integer
- * 2 => Positive large integer
-* Followed by the value:
- * Int64 is encoded as usual
- * Large integers are encoded as a list of bytes (Word8).
- We use Data.Bits which defines a bit order independent of the representation.
- Values are stored LSB first.
+In practice interface files have enough small values to make this tradeoff worthwhile.
+We could also restore this benefit by using one or two *bits* rather than a full
+byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
+gone as for for the sake of avoiding complexity.
-This means our example value `2724268014499746065` is now only 10 bytes large.
-* One byte tag
-* One byte for the length of the [Word8] list.
-* 8 bytes for the actual date.
-The new scheme also does not depend in any way on
-architecture specific details.
-
-We still use this scheme even with LEB128 available,
-as it has less overhead for truly large numbers. (> maxBound :: Int64)
-
-The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}
instance Binary Integer where
- put_ bh i
- | i >= lo64 && i <= hi64 = do
- putWord8 bh 0
- put_ bh (fromIntegral i :: Int64)
- | otherwise = do
- if i < 0
- then putWord8 bh 1
- else putWord8 bh 2
- put_ bh (unroll $ abs i)
+ -- See Note [Integer serialisation]
+ put_ bh (IS i)
+ = putSLEB128 bh (I# i)
+ put_ bh large_i
+ = putSLEB128 bh large_i
where
- lo64 = fromIntegral (minBound :: Int64)
- hi64 = fromIntegral (maxBound :: Int64)
- get bh = do
- int_kind <- getWord8 bh
- case int_kind of
- 0 -> fromIntegral <$!> (get bh :: IO Int64)
- -- Large integer
- 1 -> negate <$!> getInt
- 2 -> getInt
- _ -> panic "Binary Integer - Invalid byte"
- where
- getInt :: IO Integer
- getInt = roll <$!> (get bh :: IO [Word8])
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
+ get bh = getSLEB128Integer bh
-roll :: [Word8] -> Integer
-roll = foldl' unstep 0 . reverse
+-- | Read an SLEB128 encoded 'Integer'.
+--
+-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
+-- 'Integer' lacks. See Note [Integer serialisation].
+getSLEB128Integer :: ReadBinHandle -> IO Integer
+getSLEB128Integer bh = go_word 0 0
where
- unstep a b = a `shiftL` 8 .|. fromIntegral b
+ -- Accumulate in a Word64 for as long as possible
+ go_word :: Int -> Word64 -> IO Integer
+ go_word !shift !acc = do
+ byte <- getByte bh
+ let !byteVal = clearBit byte 7
+ let more = testBit byte 7
+ let !shift' = shift + 7 -- bits read *after* this step
+ -- Check if the payload still fits in the accumulator,
+ -- if not swap to a Integer accumulator.
+ if shift' <= 64
+ then do
+ let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
+ if more
+ then go_word shift' acc'
+ else return $! signExtendWord shift' acc' (testBit byte 6)
+ else do
+ -- They don't, so from here on out we use Integer arithmetic.
+ let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ go_big :: Int -> Integer -> IO Integer
+ go_big !shift !acc = do
+ byte <- getByte bh
+ let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift + 7
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ -- Sign extend a value of which we read `shift` bits into a Word64.
+ -- `shift` is always <= 64 here, so the result always fits into an Int64.
+ signExtendWord :: Int -> Word64 -> Bool -> Integer
+ signExtendWord !shift !acc signed
+ | not signed
+ = toInteger acc
+ | shift < 64
+ -- set high bits not encoded in the payload
+ = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
+ | otherwise
+ = toInteger (fromIntegral acc :: Int64)
+
+ -- Sign extend into an Integer.
+ signExtendInteger :: Int -> Integer -> Bool -> Integer
+ signExtendInteger !shift !acc signed
+ | signed = acc - (1 `shiftL` shift)
+ | otherwise = acc
{-
=====================================
testsuite/tests/utils/should_run/Binary_Literal.hs
=====================================
@@ -0,0 +1,280 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+-- LLM generated test. So if it's weird it's for no good reason.
+--
+-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
+--
+-- We check that
+-- * arbitrary literals round trip through 'put_' and 'get',
+-- * a whole batch of literals written into one buffer reads back in order,
+-- that is the reader consumes exactly the bytes the writer produced,
+-- * and, since numeric literals carry an 'Integer', that the SLEB128 based
+-- 'Binary Integer' instance agrees with a reference implementation.
+module Main (main) where
+
+import GHC.Data.FastString
+import GHC.Platform ( genericPlatform )
+import GHC.Types.Basic ( FunctionOrData(..) )
+import GHC.Types.Literal
+import GHC.Types.Literal.Floating
+import GHC.Utils.Binary
+
+import Control.Monad ( replicateM )
+import Data.Bits
+import qualified Data.ByteString as BS
+import Data.Ratio ( (%) )
+import Data.Word
+import GHC.Float ( castFloatToWord32, castWord32ToFloat
+ , castDoubleToWord64, castWord64ToDouble )
+import Numeric ( showHex )
+import System.IO.Unsafe ( unsafePerformIO )
+
+import MiniQuickCheck
+
+--------------------------------------------------------------------------------
+-- Encoding and decoding
+
+-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
+-- through a table in the handle's user data. Interface files fill this in with
+-- a deduplication table. We only need something that round trips, so we write
+-- the bytes of the string inline.
+withFastStringWriter :: WriteBinHandle -> WriteBinHandle
+withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
+
+withFastStringReader :: ReadBinHandle -> ReadBinHandle
+withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
+
+-- | Serialise the values and also return the position after the last of them.
+encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
+encodeAll xs = unsafePerformIO $ do
+ bh <- withFastStringWriter <$> openBinMem 1024
+ mapM_ (put_ bh) xs
+ end <- tellBinWriter bh
+ bs <- withBinBuffer bh (return . BS.copy)
+ return (bs, end)
+
+encode :: Binary a => a -> BS.ByteString
+encode x = fst (encodeAll [x])
+
+-- | Read back @n@ values and check that doing so consumed exactly the bytes
+-- the writer produced, no more and no less.
+decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
+decodeAll n (bs, end) = unsafePerformIO $ do
+ bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
+ xs <- replicateM n (get bh)
+ end' <- tellBinReader bh
+ if end' == end
+ then return xs
+ else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
+
+roundTrip :: Binary a => [a] -> [a]
+roundTrip xs = decodeAll (length xs) (encodeAll xs)
+
+roundTrip1 :: Binary a => a -> a
+roundTrip1 x = case roundTrip [x] of
+ [x'] -> x'
+ _ -> error "roundTrip1"
+
+--------------------------------------------------------------------------------
+-- Literals with structural equality and a Show instance
+
+-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
+-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
+-- identifies the different representations of the same value. For a
+-- serialisation test we want the stricter notion.
+newtype Lit = Lit Literal
+
+instance Show Lit where
+ show (Lit l) = showLit l
+
+instance Eq Lit where
+ Lit a == Lit b = eqLit a b
+
+eqLit :: Literal -> Literal -> Bool
+eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
+ = fs1 == fs2 && fod1 == fod2
+eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
+ -- 'Eq LitFloating' compares NaNs bitwise but identifies different
+ -- representations of the same value; the derived 'Show' distinguishes the
+ -- representations but not NaN payloads. Together they compare structurally.
+ = ty1 == ty2 && v1 == v2 && show v1 == show v2
+eqLit a b = a == b
+
+showLit :: Literal -> String
+showLit lit = case lit of
+ LitChar c -> "LitChar " ++ show c
+ LitNumber nt i -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
+ LitString bs -> "LitString " ++ show bs
+ LitNullAddr -> "LitNullAddr"
+ LitRubbish {} -> "LitRubbish"
+ LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
+ LitLabel fs fod -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
+ where
+ -- The bit pattern is needed to tell apart NaNs.
+ bits LitFloat v = "0x" ++ showHex (castFloatToWord32 (litFloatingToHostFloat v)) ""
+ bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
+
+ showFod IsFunction = "IsFunction"
+ showFod IsData = "IsData"
+
+showLitNumType :: LitNumType -> String
+showLitNumType nt = case nt of
+ LitNumBigNat -> "LitNumBigNat"
+ LitNumInt -> "LitNumInt"
+ LitNumInt8 -> "LitNumInt8"
+ LitNumInt16 -> "LitNumInt16"
+ LitNumInt32 -> "LitNumInt32"
+ LitNumInt64 -> "LitNumInt64"
+ LitNumWord -> "LitNumWord"
+ LitNumWord8 -> "LitNumWord8"
+ LitNumWord16 -> "LitNumWord16"
+ LitNumWord32 -> "LitNumWord32"
+ LitNumWord64 -> "LitNumWord64"
+
+--------------------------------------------------------------------------------
+-- Generators
+
+-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
+-- more random ones.
+choose :: Int -> Gen Int
+choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
+
+oneOf :: [Gen a] -> Gen a
+oneOf gens = do
+ i <- choose (length gens)
+ gens !! i
+
+listOf :: Int -> Gen a -> Gen [a]
+listOf maxLen gen = do
+ n <- choose (maxLen + 1)
+ replicateM n gen
+
+-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
+-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
+-- values and values around powers of two.
+genInteger :: Gen Integer
+genInteger = oneOf
+ [ arbitrary
+ , fromIntegral . subtract 300 <$> choose 601
+ , do k <- choose 200
+ d <- subtract 2 <$> choose 5
+ neg <- arbitrary
+ let v = 2 ^ k + toInteger d
+ return (if neg then negate v else v)
+ ]
+
+genLitNumType :: Gen LitNumType
+genLitNumType = oneOf (map pure [LitNumBigNat ..])
+
+-- | Numeric literals are always in range for their type, see
+-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
+-- free to rely on that, so we generate only such literals.
+genLitNumber :: Gen Literal
+genLitNumber = do
+ nt <- genLitNumType
+ i <- genInteger
+ -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
+ -- refuses negative 'BigNat's.
+ let i' | LitNumBigNat <- nt = abs i
+ | otherwise = i
+ return (mkLitNumberWrap genericPlatform nt i')
+
+-- | Random bit patterns, so that we also get infinities, negative zero,
+-- subnormals and NaNs with various payloads.
+genFloat :: Gen Float
+genFloat = castWord32ToFloat <$> arbitrary
+
+genDouble :: Gen Double
+genDouble = castWord64ToDouble <$> arbitrary
+
+genRational :: Gen Rational
+genRational = do
+ n <- genInteger
+ NonZero d <- arbitrary @(NonZero Integer)
+ return (n % d)
+
+genLitFloating :: Gen LitFloating
+genLitFloating = oneOf
+ [ floatToLitFloating <$> genFloat
+ , doubleToLitFloating <$> genDouble
+ , rationalToLitFloating <$> genRational
+ ]
+
+genLitFloatingType :: Gen LitFloatingType
+genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
+
+genByteString :: Gen BS.ByteString
+genByteString = BS.pack <$> listOf 64 arbitrary
+
+genFunctionOrData :: Gen FunctionOrData
+genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
+
+-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
+-- Note [Rubbish literals] in GHC.Types.Literal.
+genLiteral :: Gen Literal
+genLiteral = oneOf
+ [ LitChar <$> arbitrary
+ , genLitNumber
+ , LitString <$> genByteString
+ , pure LitNullAddr
+ , LitFloating <$> genLitFloatingType <*> genLitFloating
+ , LitLabel <$> (mkFastStringByteString <$> genByteString) <*> genFunctionOrData
+ ]
+
+instance Arbitrary Lit where
+ arbitrary = Lit <$> genLiteral
+
+newtype Lits = Lits [Lit]
+ deriving (Eq, Show)
+
+instance Arbitrary Lits where
+ arbitrary = Lits <$> listOf 32 arbitrary
+
+newtype I = I Integer
+ deriving (Eq, Show)
+
+instance Arbitrary I where
+ arbitrary = I <$> genInteger
+
+--------------------------------------------------------------------------------
+-- Properties
+
+-- | Reference implementation of the SLEB128 encoding.
+slebRef :: Integer -> [Word8]
+slebRef = go
+ where
+ go val =
+ let byte = fromIntegral (val .&. 0x7f) :: Word8
+ val' = val `shiftR` 7
+ signBit = testBit byte 6
+ done = (val' == 0 && not signBit) || (val' == -1 && signBit)
+ in if done
+ then [byte]
+ else setBit byte 7 : go val'
+
+prop_literalRoundTrip :: Lit -> PropertyCheck
+prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
+
+prop_literalBatchRoundTrip :: Lits -> PropertyCheck
+prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
+
+prop_integerRoundTrip :: I -> PropertyCheck
+prop_integerRoundTrip (I i) = roundTrip1 i === i
+
+prop_integerEncoding :: I -> PropertyCheck
+prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
+
+tests :: Test
+tests = Group "Binary"
+ [ Group "Literal"
+ [ Property "round trip" prop_literalRoundTrip
+ , Property "batch round trip" prop_literalBatchRoundTrip
+ ]
+ , Group "Integer"
+ [ Property "round trip" prop_integerRoundTrip
+ , Property "SLEB128 encoding" prop_integerEncoding
+ ]
+ ]
+
+main :: IO ()
+main = runTestsMain (Iterations 1000) tests
=====================================
testsuite/tests/utils/should_run/Binary_Literal.stdout
=====================================
@@ -0,0 +1,11 @@
+Group Binary
+ Group Literal
+ Running round trip
+ Passed 1000 iterations
+ Running batch round trip
+ Passed 1000 iterations
+ Group Integer
+ Running round trip
+ Passed 1000 iterations
+ Running SLEB128 encoding
+ Passed 1000 iterations
=====================================
testsuite/tests/utils/should_run/all.T
=====================================
@@ -1 +1,6 @@
test('T15953', [ignore_stdout, js_skip], makefile_test, [])
+
+# Property tests for the 'Binary Literal' instance, which also exercises
+# GHCs 'Binary Integer' instance.
+test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
+ ['Binary_Literal', '-package ghc'])
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -60,6 +60,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Data.Text as T
import Haddock.Options (Visibility (..))
+import qualified Data.Bits as Bits
data InterfaceFile = InterfaceFile
{ ifLinkEnv :: LinkEnv
@@ -143,7 +144,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
-binaryInterfaceVersion = 47
+binaryInterfaceVersion = 48
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -274,7 +275,7 @@ putName
do
(symtab_map, symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putNameIndex (fromIntegral off :: Word32)
Nothing -> do
off <- freshIndex
let mod' = nameModule name
@@ -283,8 +284,10 @@ putName
let !symtab_map' = extendNameEnv symtab_map name off
let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
- put_ bh (fromIntegral off :: Word32)
+ putNameIndex (fromIntegral off)
where
+ putNameIndex :: Word32 -> IO ()
+ putNameIndex off = put_ bh (off `Bits.shiftL` 1)
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1eab429f379e70d1d4115823305c3c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1eab429f379e70d1d4115823305c3c…
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/9.14.2-rc2] 8 commits: Strip ticks when desugaring bool guards
by Zubin (＠wz1000) 15 Sep '26
by Zubin (＠wz1000) 15 Sep '26
15 Sep '26
Zubin pushed to branch wip/9.14.2-rc2 at Glasgow Haskell Compiler / GHC
Commits:
5d61a09a by Brian McKenna at 2026-09-15T11:40:21+05:30
Strip ticks when desugaring bool guards
The special `considerAccessible` pattern was broken when compiling
with debug info. Compiling with debug info wraps expressions with
`SourceNote` ticks, which broke the internals of the
`desugarBoolGuard` function. Ticks are now ignored within this
function.
Fixes #27360
(cherry picked from commit d43a7b7ad90047f1445c88d796ee7b15a0a605d7)
- - - - -
9b378798 by Brian McKenna at 2026-09-15T11:40:43+05:30
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
(cherry picked from commit b388d0934c0933c1cdb47226489634e229239d0a)
- - - - -
dc9736e2 by Duncan Coutts at 2026-09-15T11:40:43+05:30
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.
(cherry picked from commit 42918646169c7c5ba61912b39b5f5147bf1d255c)
- - - - -
26b4579d by Luite Stegeman at 2026-09-15T11:40:43+05:30
rts: fix ctoi_tuple_spill_words getting out of sync
Fix a few places that were not updating ctoi_tuple_spill_words
correctly, leading to corruption/crashes when dealing with large
unboxed tuples in bytecode:
- captureContinuationAndAbort
- findRetryFrameHelper/findAtomicallyFrameHelper
- interpretBCO bci_BRK_FUN
fixes #27633
(cherry picked from commit 192be0b6b861725613a9be5cb1587fb8cdf68bd3)
- - - - -
d83131b0 by Luite Stegeman at 2026-09-15T11:41:19+05:30
rts: Fix missing memory barrier in eval_thunk_selector (#27477)
unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.
Fixes #27477
(cherry picked from commit 06eee015be4e361fe9cb33e8a608ab2ea1386b52)
- - - - -
230be88b by Zubin Duggal at 2026-09-15T11:49:08+05:30
ci: bootstrap with GHC 9.10.3 and 9.12.4
- - - - -
b959b17f by Zubin Duggal at 2026-09-15T11:49:11+05:30
Prepare 9.14.2-rc2
-------------------------
Metric Decrease:
T4029
-------------------------
- - - - -
37caf921 by Zubin Duggal at 2026-09-15T11:49:11+05:30
fixup! Prepare 9.14.2-rc2
- - - - -
46 changed files:
- .gitlab-ci.yml
- − changelog.d/27626
- − changelog.d/27627
- − changelog.d/27703
- − changelog.d/27704
- − changelog.d/27717
- − changelog.d/T26423
- − changelog.d/T26716
- − changelog.d/T27202
- − changelog.d/T27308
- − changelog.d/T27440
- − changelog.d/T27455
- − changelog.d/T27583
- − changelog.d/T27586
- − changelog.d/T27639
- − changelog.d/T27657
- − changelog.d/T27705
- − changelog.d/arm_ncg_fixes_T27430
- − changelog.d/llvm-23
- − changelog.d/unit-index
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- docs/users_guide/9.14.2-notes.rst
- libraries/base/changelog.md
- rts/Continuation.c
- rts/Interpreter.c
- rts/Schedule.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- + testsuite/tests/bytecode/T27633/Obj.hs
- + testsuite/tests/bytecode/T27633/T27633a.hs
- + testsuite/tests/bytecode/T27633/T27633a.stdout
- + testsuite/tests/bytecode/T27633/T27633b.hs
- + testsuite/tests/bytecode/T27633/T27633b.stdout
- + testsuite/tests/bytecode/T27633/all.T
- + testsuite/tests/ghci.debugger/scripts/T27633c.hs
- + testsuite/tests/ghci.debugger/scripts/T27633c.script
- + testsuite/tests/ghci.debugger/scripts/T27633c.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs
- testsuite/tests/ghci.debugger/scripts/all.T
- + testsuite/tests/pmcheck/should_compile/T27314.hs
- + testsuite/tests/pmcheck/should_compile/T27360.hs
- testsuite/tests/pmcheck/should_compile/all.T
- + testsuite/tests/rts/T27477.hs
- + testsuite/tests/rts/T27477.stdout
- testsuite/tests/rts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0257f81be0b8336d8c40225b49a6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0257f81be0b8336d8c40225b49a6…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
7731667b by Andreas Klebinger at 2026-09-15T06:13:26+00:00
.hi files: Various encoding improvements
Binders: Encode non-linear binders more efficiently.
There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.
Names: Use the low rather than high bit to encode the "compactness".
Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.
This allows use to LEB128 encode the combination of tag + value efficiently.
instance Binary Integer:
We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.
Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.
instance Binary iteral:
Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.
This saves a byte per literal for small numbers.
`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.
We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:
IfaceApps IfaceExpr [IfaceExpr]
Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.
Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.
`IfaceAlt`: Improve the encoding
We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.
`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.
Generally .hi files get a few % smaller. With a relative big variance with some files
getting more then 20% smaller.
-------------------------
Metric Decrease:
if_ifacetype
-------------------------
- - - - -
14 changed files:
- + changelog.d/T27808-iface-encoding-improvements
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Utils/Binary.hs
- + testsuite/tests/utils/should_run/Binary_Literal.hs
- + testsuite/tests/utils/should_run/Binary_Literal.stdout
- testsuite/tests/utils/should_run/all.T
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
+issues: #27808
+mrs: !16683
+description: {
+ This was mostly done by moving from simple pointwise encoding to adding
+ special cases for common cases.
+}
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
+-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
+-- See Note [Iface applications] in GHC.Iface.Syntax
+mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
= -- See Note [Inlining and hs-boot files]
- IfaceApp (IfaceApp (IfaceExt noinline_id)
- (IfaceType (toIfaceType ty)))
- (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
+ IfaceApps (IfaceExt noinline_id)
+ [IfaceType (toIfaceType ty), IfaceExt name]
+ -- don't use mkIfaceApps, or infinite loop since it ends up calling
+ -- toIfaceVar indirectly again.
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -741,25 +741,38 @@ In more detail:
Tuples aren't included in the wired-in names map: see (ST1) below
* Serialisation is done by `putName`:
- - When we serialise a compact Name,
- we serialise it as a single 32-bit word:
- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
- where xxxx is the tag, and yyyy is the payload.
- The function `wiredInNamesOkay` checks that the wired-in names all have
- uniques that fit into the `yyy` field.
+ - When we serialise a compact Name, we serialise its Unique, split by
+ `unpkUniqueGrimily` into the tag character and the payload:
+
+ yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
+ \________ payload _______/\_ tag _/^ marker bit
+
+ Why are we storing the marker/tag in the low rather than high bits? Because
+ we LEB128 encode the whole word when writing to disk so we want to keep as
+ many of the high bits zero as possible to allow for shorter encodings. See
+ also wrinkle ST3.
+
+ Tags are 8 bits by construction, and there is a check that the actual unique
+ part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
+ known-key names.
- When we serialise a non-compact name:
- We look it up in the (stateful, growing) symbol table
- - If it not there we add it to the symbol table
- - We serialise the occurrenc to a single 32-bit word:
- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
- where `xxxxx` is an index into the symbol table.
+ - If it is not there we add it to the symbol table
+ - We serialise the occurrence as
-* Deserialision is done by `getName`. We read a 32-bit word
- - If the MSB is `10` it must be a compact name, so we use
+ 0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
+
+ In other words we simply shift the index by a bit.
+ The high bit is currently unused. But `putSymtabNameRef`
+ asserts that `ix` fits in 30 bits.
+
+* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
+ of the word it reads:
+ - If it is 1 it must be a compact name, so we reassemble the Unique and use
`lookupCompactName` to get from the Unique to the Name.
- - If the MSB is `00` it must be a non-compact Name,
- so we look it up in the symbol table.
+ - If it is 0 it must be a non-compact Name, so we look it up in the
+ symbol table.
Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
`isCompactName` that tests for `knownUniqueTupleName` and then the
TyConRepNames would be serialised as non-compact names, and everything would
work. Fewer tests, but Typeable-heavy code might have bigger interface files.
+
+(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
+ disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
+ This has consequences as it means we want to keep the high bits zero where possible
+ to allow for a shorter ULEB128 encoding.
+
+ This is why we put both the tag and the marker bit at the LSB end of the word. They
+ are always present. But by putting them at the low end we ensure LEB128 encoding
+ still works as expected, producing smaller encodings for compact names with small
+ uniques.
+
+ The downside is that we steal one bit from non-compact names for which the marker
+ bit and tag would have been zero either way. But in practice this matters far less
+ than ensuring built in (compact) names encode well.
-}
isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
where
(tag, ix) = unpkUniqueGrimily u
+-- | Write a reference to a symbol table index.
+-- See Note [Symbol table representation of names]
+putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
+{-# INLINE putSymtabNameRef #-}
+putSymtabNameRef bh ix
+ = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
+ (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
+ -- Bit 0 == False marks a symbol table reference
+ put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
+
+-- | Write a reference to a compact (known-key) 'Name'.
+-- See Note [Symbol table representation of names]
+putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
+{-# INLINE putCompactNameRef #-}
+putCompactNameRef bh uniq
+ = -- INVARIANTS:
+ -- * 8 bits tag (true by construction)
+ -- * the payload fits in 22 bits (checked for all known keys elsewhere)
+ -- Bit 0 == True marks a compact (known-key) name
+ put_ bh ( (fromIntegral payload `shiftL` 9)
+ .|. (fromIntegral (ord tag) `shiftL` 1)
+ .|. 1 :: Word32)
+ where
+ (tag, payload) = unpkUniqueGrimily uniq
+
-- See Note [Symbol table representation of names]
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isCompactName name
- , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
+ = putCompactNameRef bh (nameUnique name)
| otherwise
= do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putSymtabNameRef bh off
Nothing -> do
off <- freshIndex
let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
- put_ bh (fromIntegral off :: Word32)
+ putSymtabNameRef bh off
where
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral i
- 0x80000000 -> return $! lookupCompactName u
- where
- tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- u = mkUniqueGrimilyWithTag tag ix
-
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+ if i .&. 1 == 0
+ then -- Symbol table reference, written by putSymtabNameRef
+ return $! symtab ! fromIntegral (i `shiftR` 1)
+ else -- Compact name, written by putCompactNameRef
+ let tag = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
+ payload = fromIntegral (i `shiftR` 9) :: Word64
+ in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
= IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
= IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceApps fun args)
+ = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
rnIfaceExpr (IfaceCase scrut case_bndr alts)
= IfaceCase <$> rnIfaceExpr scrut
<*> pure case_bndr
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
+ IfaceExpr(..), mkIfaceApp,
+ IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- zipWithEqual )
+import GHC.Utils.Misc( dropList, filterByList, notNull,
+ unzipWith, zipWithEqual )
import GHC.Data.FastString
import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceLamBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
+ -- ^ Application to exactly one argument.
+ -- See Note [Iface applications]
+ | IfaceApps IfaceExpr [IfaceExpr]
+ -- ^ Application to two or more arguments.
+ -- See Note [Iface applications]
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+-- | Apply an expression to a (possibly empty) list of arguments, maintaining
+-- the invariants of 'IfaceApp' and 'IfaceApps'.
+-- See Note [Iface applications].
+mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
+mkIfaceApp fun args = go fun args
+ where
+ go (IfaceApp f a) as = go f (a : as)
+ go (IfaceApps f fs) as = go f (fs ++ as)
+
+ go f [] = f
+ go f [a] = IfaceApp f a
+ go f as = IfaceApps f as
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
{-
+Note [Iface applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A Core application chain (f a1 a2 ... an) could be represented by a chain of
+n nested IfaceApp nodes like Core does. However this is generally a worse
+representation for *serialization* which is the main purpose of the Iface type.
+
+So we keep the single argument constructor as it's fairly common, and add one
+to represent multiple arguments:
+
+ * IfaceApp f a -- exactly one argument
+ * IfaceApps f [a1,..] -- two or more arguments
+
+with two invariants:
+
+ (1) The argument list of an IfaceApps has at least two elements.
+ (A one-argument application is an IfaceApp, and a zero-argument
+ "application" is just the head itself.)
+
+ (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
+ IfaceApps: application chains are fully flattened.
+
+The smart constructor 'mkIfaceApp' establishes both invariants; producers
+should use it rather than building IfaceApps directly.
+
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
<> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
<> parens (ppr r)
-pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
+-- that --show-iface output does not depend on which one the producer emitted.
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
nest 2 (pprParendIfaceExpr arg) : args
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApps fun as) args = pprIfaceApp fun $
+ map (nest 2 . pprParendIfaceExpr) as ++ args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceApps f as) = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
{-# INLINE (.<<|.) #-}
+-- Encoding shortcuts:
+-- Since only IfaceDataAlt can have binders
+-- we can skip the binder list for DEFAULT and Literal alternatives.
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
- put_ bh b
+ case a of
+ IfaceDataAlt {} -> put_ bh b
+ _ -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
put_ bh c
get bh = do
a <- get bh
- b <- get bh
+ b <- case a of
+ IfaceDataAlt {} -> get bh
+ _ -> return []
c <- get bh
return (IfaceAlt a b c)
+{- Note [IfaceExpr encoding shortcuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use a full byte to encode the constructor tag for `IfaceExpr`.
+This leaves room to encode additional information. Concretely we
+use:
+
+0 .. 14: "Simple" constructor tags.
+15 .. 22: "IfaceApps", encoding the constructor *and* arity.
+ 23: "IfaceCase" for a case with a single default alternative.
+
+Note [Binary encoding of IfaceApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For IfaceApps we use the following scheme:
+
+ * arity 2..8: one byte encoding the arity as (15 + (n-2))
+ Which is followed by the head expression and then exactly `arity` arguments.
+
+ * arity > 8: tag 22, and we serialize the argument count as a ULEB128, followed by the
+ head expression and arguments.
+
+This saves us one byte per application with `2 <= arity <= 8`.
+-}
instance Binary IfaceExpr where
put_ bh (IfaceLcl aa) = do
putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
putByte bh 5
put_ bh ag
put_ bh ah
+ -- See Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
+ putByte bh 23
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
put_ bh (IfaceCase ai aj ak) = do
putByte bh 6
put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
putByte bh 14
put_ bh r
put_ bh torc
+ -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
+ -- and Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceApps fun args) = do
+ let !n = length args
+ massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
+ if n <= maxIfaceAppsTagArity
+ then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
+ else do putByte bh (fromIntegral ifaceAppsBigTag)
+ put_ bh n
+ put_ bh fun
+ mapM_ (put_ bh) args
get bh = do
h <- getByte bh
case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
14 -> do r <- get bh
torc <- get bh
return (IfaceLitRubbish torc r)
+ -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
+ -- tag 22 is followed by an explicit (LEB128) argument count.
+ -- See Note [Binary encoding of IfaceApps]
+ 15 -> getApps 2
+ 16 -> getApps 3
+ 17 -> getApps 4
+ 18 -> getApps 5
+ 19 -> getApps 6
+ 20 -> getApps 7
+ 21 -> getApps 8
+ 22 -> do n <- get bh
+ getApps n
+ -- case scrut of bndr { DEFAULT -> rhs}
+ 23 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
_ -> panic ("get IfaceExpr " ++ show h)
+ where
+ getApps :: Int -> IO IfaceExpr
+ getApps n = do fun <- get bh
+ args <- replicateM n (get bh)
+ return (IfaceApps fun args)
+-- | Tag used for an 'IfaceApps' with exactly two arguments and start
+-- of the ifaceApps tag range.
+ifaceAppsTag0 :: Int
+ifaceAppsTag0 = 15
+
+-- | Highest arity encoded directly in tag byte.
+maxIfaceAppsTagArity :: Int
+maxIfaceAppsTagArity = 8
+
+-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
+ifaceAppsBigTag :: Int
+ifaceAppsBigTag = 22
instance Binary IfaceTickish where
put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
+ IfaceApps e es -> rnf e `seq` rnf es
IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
where
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
+-- | IfaceBndr shortcuts:
+--
+-- In the vast majority of cases binder multiplicity is `Many` so storing it is
+-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
+-- (Name,Ty) in the common case where multiplicity == Many.
instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr (mult, name, ty))
+ -- The implicit Many shortcut.
+ | mult == many_ty = do
+ putByte bh 2
+ put_ bh name
+ put_ bh ty
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
- _ -> do ab <- get bh
+ 1 -> do ab <- get bh
return (IfaceTvBndr ab)
+ _ -> do name <- get bh
+ ty <- get bh
+ return (IfaceIdBndr (many_ty, name, ty))
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot =
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceApps f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+tcIfaceExpr (IfaceApps fun args)
+ = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
+
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -167,7 +167,7 @@ data LitNumType
| LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
| LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
- deriving (Data,Enum,Eq,Ord)
+ deriving (Data,Enum,Eq,Ord,Bounded)
-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
-}
+{-
+Note [Binary Literal encoding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than write `LitNumType` into it's own tag byte we encode it in the
+surplus space of the `Literal` tag space.
+
+This means for `Literal` tag 0 .. 5 are the non-num literals.
+Literals 6 .. (maxBound LitNumType) encode the LitNumType.
+
+We could use the `LitNumType` information to slightly improve the encoding of
+the actual values too. But we just write/read them at Integer for simplicity for
+now.
+-}
+
+-- | The 'Binary' tag byte of @'LitNumber' nt _@.
+--
+-- These continue the tags of the non-numeric 'Literal' constructors. The
+-- mapping is total and part of the interface file format.
+-- See Note [Binary Literal encoding].
+litNumTypeTag :: LitNumType -> Word8
+litNumTypeTag nt =
+ -- 6 .. 16
+ 6 + (fromIntegral $ fromEnum nt)
+
+-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
+-- of a numeric literal. See Note [Binary Literal encoding].
+litNumTypeOfTag :: Word8 -> Maybe LitNumType
+litNumTypeOfTag tag
+ | tag >= 6 && tag <= 16
+ = Just (toEnum $ (fromIntegral tag) - 6)
+ | otherwise = Nothing
+
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
= do putByte bh 5
put_ bh aj
put_ bh fod
+ -- The LitNumType is part of the tag byte.
+ -- See Note [Binary Literal encoding]
put_ bh (LitNumber nt i)
- = do putByte bh 6
- put_ bh nt
+ = do putByte bh (litNumTypeTag nt)
put_ bh i
put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
-- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
aj <- get bh
fod <- get bh
return (LitLabel aj fod)
- 6 -> do
- nt <- get bh
- i <- get bh
- return (LitNumber nt i)
- _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+ _ | Just nt <- litNumTypeOfTag h
+ -> do i <- get bh
+ return (LitNumber nt i)
+ | otherwise
+ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance NFData Literal where
rnf (LitChar c) = rnf c
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
case unpkUniqueGrimily u of
- (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+ (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -148,7 +148,7 @@ import GHCi.FFI
import GHCi.Message
import Control.DeepSeq
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Control.Monad ( when, unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time hiding ( Nominal )
-import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import Type.Reflection ( Typeable, SomeTypeRep(..) )
@@ -188,6 +187,7 @@ import GHC.ForeignPtr ( unsafeWithForeignPtr )
import GHC.Exts
import GHC.IO
import GHC.Word
+import GHC.Num (Integer(IS))
import Unsafe.Coerce (unsafeCoerce)
import GHC.Serialized
@@ -805,6 +805,7 @@ getULEB128 bh =
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
@@ -1123,86 +1124,91 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-We used to encode values in the Int32 range as such,
-falling back to a string of all things. In either case
-we stored a tag byte to discriminate between the two cases.
+This is a tradeoff:
+It allows shorter encodings for the common case of small values. And we don't need
+to prefix the string with a byte carrying any information about size or sign.
-This made some sense as it's highly portable but also not very
-efficient.
+However it means large Integer values will pay some overhead. Their encoding can
+go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
+into a `Integer` accumulator rather than a simple Word64#.
-However GHC stores a surprisingly large number of large Integer
-values. In the examples looked at between 25% and 50% of Integers
-serialized were outside of the Int32 range.
+In practice interface files have enough small values to make this tradeoff worthwhile.
+We could also restore this benefit by using one or two *bits* rather than a full
+byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
+gone as for for the sake of avoiding complexity.
-Consider a value like `2724268014499746065`, some sort of hash
-actually generated by GHC.
-In the old scheme this was encoded as a list of 19 chars. This
-gave a size of 77 Bytes, one for the length of the list and 76
-since we encode chars as Word32 as well.
-We can easily do better. The new plan is:
-
-* Start with a tag byte
- * 0 => Int64 (LEB128 encoded)
- * 1 => Negative large integer
- * 2 => Positive large integer
-* Followed by the value:
- * Int64 is encoded as usual
- * Large integers are encoded as a list of bytes (Word8).
- We use Data.Bits which defines a bit order independent of the representation.
- Values are stored LSB first.
-
-This means our example value `2724268014499746065` is now only 10 bytes large.
-* One byte tag
-* One byte for the length of the [Word8] list.
-* 8 bytes for the actual date.
-
-The new scheme also does not depend in any way on
-architecture specific details.
-
-We still use this scheme even with LEB128 available,
-as it has less overhead for truly large numbers. (> maxBound :: Int64)
-
-The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}
instance Binary Integer where
- put_ bh i
- | i >= lo64 && i <= hi64 = do
- putWord8 bh 0
- put_ bh (fromIntegral i :: Int64)
- | otherwise = do
- if i < 0
- then putWord8 bh 1
- else putWord8 bh 2
- put_ bh (unroll $ abs i)
+ -- See Note [Integer serialisation]
+ put_ bh (IS i)
+ = putSLEB128 bh (I# i)
+ put_ bh large_i
+ = putSLEB128 bh large_i
where
- lo64 = fromIntegral (minBound :: Int64)
- hi64 = fromIntegral (maxBound :: Int64)
- get bh = do
- int_kind <- getWord8 bh
- case int_kind of
- 0 -> fromIntegral <$!> (get bh :: IO Int64)
- -- Large integer
- 1 -> negate <$!> getInt
- 2 -> getInt
- _ -> panic "Binary Integer - Invalid byte"
- where
- getInt :: IO Integer
- getInt = roll <$!> (get bh :: IO [Word8])
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
+ get bh = getSLEB128Integer bh
-roll :: [Word8] -> Integer
-roll = foldl' unstep 0 . reverse
+-- | Read an SLEB128 encoded 'Integer'.
+--
+-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
+-- 'Integer' lacks. See Note [Integer serialisation].
+getSLEB128Integer :: ReadBinHandle -> IO Integer
+getSLEB128Integer bh = go_word 0 0
where
- unstep a b = a `shiftL` 8 .|. fromIntegral b
+ -- Accumulate in a Word64 for as long as possible
+ go_word :: Int -> Word64 -> IO Integer
+ go_word !shift !acc = do
+ byte <- getByte bh
+ let !byteVal = clearBit byte 7
+ let more = testBit byte 7
+ let !shift' = shift + 7 -- bits read *after* this step
+ -- Check if the payload still fits in the accumulator,
+ -- if not swap to a Integer accumulator.
+ if shift' <= 64
+ then do
+ let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
+ if more
+ then go_word shift' acc'
+ else return $! signExtendWord shift' acc' (testBit byte 6)
+ else do
+ -- They don't, so from here on out we use Integer arithmetic.
+ let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ go_big :: Int -> Integer -> IO Integer
+ go_big !shift !acc = do
+ byte <- getByte bh
+ let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift + 7
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ -- Sign extend a value of which we read `shift` bits into a Word64.
+ -- `shift` is always <= 64 here, so the result always fits into an Int64.
+ signExtendWord :: Int -> Word64 -> Bool -> Integer
+ signExtendWord !shift !acc signed
+ | not signed
+ = toInteger acc
+ | shift < 64
+ -- set high bits not encoded in the payload
+ = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
+ | otherwise
+ = toInteger (fromIntegral acc :: Int64)
+
+ -- Sign extend into an Integer.
+ signExtendInteger :: Int -> Integer -> Bool -> Integer
+ signExtendInteger !shift !acc signed
+ | signed = acc - (1 `shiftL` shift)
+ | otherwise = acc
{-
=====================================
testsuite/tests/utils/should_run/Binary_Literal.hs
=====================================
@@ -0,0 +1,280 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+-- LLM generated test. So if it's weird it's for no good reason.
+--
+-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
+--
+-- We check that
+-- * arbitrary literals round trip through 'put_' and 'get',
+-- * a whole batch of literals written into one buffer reads back in order,
+-- that is the reader consumes exactly the bytes the writer produced,
+-- * and, since numeric literals carry an 'Integer', that the SLEB128 based
+-- 'Binary Integer' instance agrees with a reference implementation.
+module Main (main) where
+
+import GHC.Data.FastString
+import GHC.Platform ( genericPlatform )
+import GHC.Types.Basic ( FunctionOrData(..) )
+import GHC.Types.Literal
+import GHC.Types.Literal.Floating
+import GHC.Utils.Binary
+
+import Control.Monad ( replicateM )
+import Data.Bits
+import qualified Data.ByteString as BS
+import Data.Ratio ( (%) )
+import Data.Word
+import GHC.Float ( castFloatToWord32, castWord32ToFloat
+ , castDoubleToWord64, castWord64ToDouble )
+import Numeric ( showHex )
+import System.IO.Unsafe ( unsafePerformIO )
+
+import MiniQuickCheck
+
+--------------------------------------------------------------------------------
+-- Encoding and decoding
+
+-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
+-- through a table in the handle's user data. Interface files fill this in with
+-- a deduplication table. We only need something that round trips, so we write
+-- the bytes of the string inline.
+withFastStringWriter :: WriteBinHandle -> WriteBinHandle
+withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
+
+withFastStringReader :: ReadBinHandle -> ReadBinHandle
+withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
+
+-- | Serialise the values and also return the position after the last of them.
+encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
+encodeAll xs = unsafePerformIO $ do
+ bh <- withFastStringWriter <$> openBinMem 1024
+ mapM_ (put_ bh) xs
+ end <- tellBinWriter bh
+ bs <- withBinBuffer bh (return . BS.copy)
+ return (bs, end)
+
+encode :: Binary a => a -> BS.ByteString
+encode x = fst (encodeAll [x])
+
+-- | Read back @n@ values and check that doing so consumed exactly the bytes
+-- the writer produced, no more and no less.
+decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
+decodeAll n (bs, end) = unsafePerformIO $ do
+ bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
+ xs <- replicateM n (get bh)
+ end' <- tellBinReader bh
+ if end' == end
+ then return xs
+ else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
+
+roundTrip :: Binary a => [a] -> [a]
+roundTrip xs = decodeAll (length xs) (encodeAll xs)
+
+roundTrip1 :: Binary a => a -> a
+roundTrip1 x = case roundTrip [x] of
+ [x'] -> x'
+ _ -> error "roundTrip1"
+
+--------------------------------------------------------------------------------
+-- Literals with structural equality and a Show instance
+
+-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
+-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
+-- identifies the different representations of the same value. For a
+-- serialisation test we want the stricter notion.
+newtype Lit = Lit Literal
+
+instance Show Lit where
+ show (Lit l) = showLit l
+
+instance Eq Lit where
+ Lit a == Lit b = eqLit a b
+
+eqLit :: Literal -> Literal -> Bool
+eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
+ = fs1 == fs2 && fod1 == fod2
+eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
+ -- 'Eq LitFloating' compares NaNs bitwise but identifies different
+ -- representations of the same value; the derived 'Show' distinguishes the
+ -- representations but not NaN payloads. Together they compare structurally.
+ = ty1 == ty2 && v1 == v2 && show v1 == show v2
+eqLit a b = a == b
+
+showLit :: Literal -> String
+showLit lit = case lit of
+ LitChar c -> "LitChar " ++ show c
+ LitNumber nt i -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
+ LitString bs -> "LitString " ++ show bs
+ LitNullAddr -> "LitNullAddr"
+ LitRubbish {} -> "LitRubbish"
+ LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
+ LitLabel fs fod -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
+ where
+ -- The bit pattern is needed to tell apart NaNs.
+ bits LitFloat v = "0x" ++ showHex (castFloatToWord32 (litFloatingToHostFloat v)) ""
+ bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
+
+ showFod IsFunction = "IsFunction"
+ showFod IsData = "IsData"
+
+showLitNumType :: LitNumType -> String
+showLitNumType nt = case nt of
+ LitNumBigNat -> "LitNumBigNat"
+ LitNumInt -> "LitNumInt"
+ LitNumInt8 -> "LitNumInt8"
+ LitNumInt16 -> "LitNumInt16"
+ LitNumInt32 -> "LitNumInt32"
+ LitNumInt64 -> "LitNumInt64"
+ LitNumWord -> "LitNumWord"
+ LitNumWord8 -> "LitNumWord8"
+ LitNumWord16 -> "LitNumWord16"
+ LitNumWord32 -> "LitNumWord32"
+ LitNumWord64 -> "LitNumWord64"
+
+--------------------------------------------------------------------------------
+-- Generators
+
+-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
+-- more random ones.
+choose :: Int -> Gen Int
+choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
+
+oneOf :: [Gen a] -> Gen a
+oneOf gens = do
+ i <- choose (length gens)
+ gens !! i
+
+listOf :: Int -> Gen a -> Gen [a]
+listOf maxLen gen = do
+ n <- choose (maxLen + 1)
+ replicateM n gen
+
+-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
+-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
+-- values and values around powers of two.
+genInteger :: Gen Integer
+genInteger = oneOf
+ [ arbitrary
+ , fromIntegral . subtract 300 <$> choose 601
+ , do k <- choose 200
+ d <- subtract 2 <$> choose 5
+ neg <- arbitrary
+ let v = 2 ^ k + toInteger d
+ return (if neg then negate v else v)
+ ]
+
+genLitNumType :: Gen LitNumType
+genLitNumType = oneOf (map pure [LitNumBigNat ..])
+
+-- | Numeric literals are always in range for their type, see
+-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
+-- free to rely on that, so we generate only such literals.
+genLitNumber :: Gen Literal
+genLitNumber = do
+ nt <- genLitNumType
+ i <- genInteger
+ -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
+ -- refuses negative 'BigNat's.
+ let i' | LitNumBigNat <- nt = abs i
+ | otherwise = i
+ return (mkLitNumberWrap genericPlatform nt i')
+
+-- | Random bit patterns, so that we also get infinities, negative zero,
+-- subnormals and NaNs with various payloads.
+genFloat :: Gen Float
+genFloat = castWord32ToFloat <$> arbitrary
+
+genDouble :: Gen Double
+genDouble = castWord64ToDouble <$> arbitrary
+
+genRational :: Gen Rational
+genRational = do
+ n <- genInteger
+ NonZero d <- arbitrary @(NonZero Integer)
+ return (n % d)
+
+genLitFloating :: Gen LitFloating
+genLitFloating = oneOf
+ [ floatToLitFloating <$> genFloat
+ , doubleToLitFloating <$> genDouble
+ , rationalToLitFloating <$> genRational
+ ]
+
+genLitFloatingType :: Gen LitFloatingType
+genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
+
+genByteString :: Gen BS.ByteString
+genByteString = BS.pack <$> listOf 64 arbitrary
+
+genFunctionOrData :: Gen FunctionOrData
+genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
+
+-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
+-- Note [Rubbish literals] in GHC.Types.Literal.
+genLiteral :: Gen Literal
+genLiteral = oneOf
+ [ LitChar <$> arbitrary
+ , genLitNumber
+ , LitString <$> genByteString
+ , pure LitNullAddr
+ , LitFloating <$> genLitFloatingType <*> genLitFloating
+ , LitLabel <$> (mkFastStringByteString <$> genByteString) <*> genFunctionOrData
+ ]
+
+instance Arbitrary Lit where
+ arbitrary = Lit <$> genLiteral
+
+newtype Lits = Lits [Lit]
+ deriving (Eq, Show)
+
+instance Arbitrary Lits where
+ arbitrary = Lits <$> listOf 32 arbitrary
+
+newtype I = I Integer
+ deriving (Eq, Show)
+
+instance Arbitrary I where
+ arbitrary = I <$> genInteger
+
+--------------------------------------------------------------------------------
+-- Properties
+
+-- | Reference implementation of the SLEB128 encoding.
+slebRef :: Integer -> [Word8]
+slebRef = go
+ where
+ go val =
+ let byte = fromIntegral (val .&. 0x7f) :: Word8
+ val' = val `shiftR` 7
+ signBit = testBit byte 6
+ done = (val' == 0 && not signBit) || (val' == -1 && signBit)
+ in if done
+ then [byte]
+ else setBit byte 7 : go val'
+
+prop_literalRoundTrip :: Lit -> PropertyCheck
+prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
+
+prop_literalBatchRoundTrip :: Lits -> PropertyCheck
+prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
+
+prop_integerRoundTrip :: I -> PropertyCheck
+prop_integerRoundTrip (I i) = roundTrip1 i === i
+
+prop_integerEncoding :: I -> PropertyCheck
+prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
+
+tests :: Test
+tests = Group "Binary"
+ [ Group "Literal"
+ [ Property "round trip" prop_literalRoundTrip
+ , Property "batch round trip" prop_literalBatchRoundTrip
+ ]
+ , Group "Integer"
+ [ Property "round trip" prop_integerRoundTrip
+ , Property "SLEB128 encoding" prop_integerEncoding
+ ]
+ ]
+
+main :: IO ()
+main = runTestsMain (Iterations 1000) tests
=====================================
testsuite/tests/utils/should_run/Binary_Literal.stdout
=====================================
@@ -0,0 +1,11 @@
+Group Binary
+ Group Literal
+ Running round trip
+ Passed 1000 iterations
+ Running batch round trip
+ Passed 1000 iterations
+ Group Integer
+ Running round trip
+ Passed 1000 iterations
+ Running SLEB128 encoding
+ Passed 1000 iterations
=====================================
testsuite/tests/utils/should_run/all.T
=====================================
@@ -1 +1,6 @@
test('T15953', [ignore_stdout, js_skip], makefile_test, [])
+
+# Property tests for the 'Binary Literal' instance, which also exercises
+# GHCs 'Binary Integer' instance.
+test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
+ ['Binary_Literal', '-package ghc'])
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -60,6 +60,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Data.Text as T
import Haddock.Options (Visibility (..))
+import qualified Data.Bits as Bits
data InterfaceFile = InterfaceFile
{ ifLinkEnv :: LinkEnv
@@ -143,7 +144,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
-binaryInterfaceVersion = 47
+binaryInterfaceVersion = 48
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -274,7 +275,7 @@ putName
do
(symtab_map, symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putNameIndex (fromIntegral off :: Word32)
Nothing -> do
off <- freshIndex
let mod' = nameModule name
@@ -283,8 +284,10 @@ putName
let !symtab_map' = extendNameEnv symtab_map name off
let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
- put_ bh (fromIntegral off :: Word32)
+ putNameIndex (fromIntegral off)
where
+ putNameIndex :: Word32 -> IO ()
+ putNameIndex off = put_ bh (off `Bits.shiftL` 1)
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7731667bbbac2203710218c74c25de0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7731667bbbac2203710218c74c25de0…
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/dcoutts/io-manager-selectbis] 7 commits: Refactor (and rename) removeFromQueues, to simplify I/O managers
by Duncan Coutts (＠dcoutts) 14 Sep '26
by Duncan Coutts (＠dcoutts) 14 Sep '26
14 Sep '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-selectbis at Glasgow Haskell Compiler / GHC
Commits:
067b3379 by Duncan Coutts at 2026-09-14T22:30:51+01:00
Refactor (and rename) removeFromQueues, to simplify I/O managers
Rename it to unblockAndAppendToRunQueue which better reflects what it is
intended to do.
The post-condition for unblockAndAppendToRunQueue is that the TSO is on
the run queue or it is in the process of migrating to another cap.
Previously it achieved that by always directly adding the TSO to the run
queue itself.
But this actually made things more complicated for the I/O managers,
because it meant they needed a separate code path for notifying for
cancellation compared to notifying for completion. The general
notification code would always add the TSO to the run queue itself.
So the improvement is to allow different cases in
unblockAndAppendToRunQueue to achieve the same outcome in different
ways: either directly adding to the run queue or calling helper
functions that do so themselves.
This then allows the new I/O managers to share code between the sync and
async cancellation, and to reuse their notifyIOCompletion helpers for
cancellation. This avoids a source of bugs where the completion path may
be updated but the cancellation path may be forgotten, or similarly in
future for sync/async operations.
Update all the existing in-RTS I/O managers, and the posix timeout code.
- - - - -
a5c3c2d2 by Duncan Coutts at 2026-09-14T22:52:02+01:00
Document that awaitCompletedTimeoutsOrIO expects an empty run queue
This was true before but implicit and not relied on much. It's better to
be explicit, and allow things to depend on it.
- - - - -
9f90058c by Duncan Coutts at 2026-09-14T22:52:58+01:00
Store the I/O opcode and fd in the StgAsyncIOOp
This will be useful in several I/O managers and it is handy for logging
and debugging.
It also doesn't increase the size of the StgAsyncIOOp structure. There
was enough spare padding space already.
Update the poll I/O manager to set the new fields.
Add a helper function to convert the enum IOReadOrWrite into the enum
IOOpCode. Also change IOReadOrWrite to be an enum without a typedef, for
consistency with other enumerations in IOManager.h
- - - - -
9e823372 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Add a new I/O manager based on select()
Yes, this is the second such I/O manager, but it is a modern
re-implementation based on the new in-RTS I/O manager infrastructure. So
it is cleaner and faster than the old select I/O manager.
Why do we need another I/O manager based on select? Why isn't the poll()
one good enough as a baseline portable unix I/O manager? Because macOS.
Apple Inc. is why we cannot have nice things.
The man page for poll on macOS documents the fact that it does not work.
At least, it does not work for all files. Specifically, it does not work
for device files. Whereas macOS select() does work for device files.
Aaaaarg!
We _do_ want to deprecate and remove the old select I/O manager, but due to
macOS we cannot do that until we have a replacement. This is that
replacement. Until of course a nice new k-queue I/O manager arrives,
which could become the new default for macOS and FreeBSD.
Interestingly, this select I/O manager is actually faster than the poll
one, on Linix, in some circumstances: specifically when many Haskell
threads are waiting on the same fd. The poll I/O manager does O(n) work
for n threads waiting on I/O, whereas the select one does O(fds) work
for the number of fds that threads are waiting on. Usually this is 1:1,
so it's not noticable, but one can concoct extreme benchmarks to show
the difference.
- - - - -
ec1c4b93 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Minor updates in the poll I/O manager to keep in sync with select
This keeps it in sync with select one. The changes are based on code review
while implementing the new select I/O manager. The two I/O managers are so
similar in structure that it makes sense to try to minimise the diff between
them. This should aid understanding, and fixes to both in future.
- - - - -
ffb39393 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Document the new select I/O manager in the user guide
in the RTS section about I/O managers.
And add a changelog entry.
- - - - -
2c4ecfe6 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Use selectbis I/O manager by default for CI coverage
This should not be committed to master.
It would be nice however to get better CI coverage of non-default I/O
managers.
- - - - -
20 changed files:
- + changelog.d/select-io-manager
- docs/users_guide/runtime_control.rst
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/RaiseAsync.c
- rts/configure.ac
- rts/include/rts/Flags.h
- rts/include/rts/storage/Closures.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- + rts/posix/SelectBis.c
- + rts/posix/SelectBis.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/rts.cabal
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
changelog.d/select-io-manager
=====================================
@@ -0,0 +1,19 @@
+section: rts
+issues: #27519
+mrs: !16359
+synopsis:
+ New I/O manager based on select()
+description:
+ There is a new I/O manager on Posix systems based on select(). This exists
+ primarily to support macOS, where the poll() API does not work correctly
+ (specifically it is documented not to work for device files). It is the new
+ default I/O manager for the non-threaded RTS for the macOS platform.
+
+ This is intended to allow the legacy select I/O manager to be retired. It is
+ also a stop-gap measure until a kqueue I/O manager is added.
+
+ The new implementation is marginally faster in some cases. It scales better
+ for timers, O(log n) rather than O(m). For threads waiting on I/O it is
+ necessarily still O(n). If used to wait on fds > 1024 it will throw an IO
+ exception rather than terminating the RTS, as was the behaviour of the old
+ select I/O manager.
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -1441,15 +1441,30 @@ limited.
Currently the available I/O managers are:
================ ========= ============
- Name Platforms RTS way
+I/O manager name Platforms RTS way
================ ========= ============
``select`` Posix Non-threaded
-``poll`` Posix Non-threaded
+``selectbis`` Posix Non-threaded
+``poll`` Posix(*) Non-threaded
``mio`` All Threaded
``win32-legacy`` Windows Non-threaded
``winio`` Windows Both
================ ========= ============
+(*) The ``poll`` I/O manager is not available on macOS due to platform
+limitations.
+
+Currently the default I/O manager on each platform is:
+
+========= ============ ===================
+Platform RTS way default I/O manager
+========= ============ ===================
+macOS Non-threaded ``selectbis``
+Posix Non-threaded ``poll``
+Windows Non-threaded ``win32-legacy``
+all Threaded ``mio``
+========= ============ ===================
+
.. rts-flag:: --io-manager=(name)
Select the I/O manager to use. On some combinations of platform and
@@ -1474,7 +1489,8 @@ This is because it uses a linked list for timers.
This I/O manager is highly portable and its code is very mature: it is the I/O
manager that has been used by GHC in the single-threaded RTS on Posix platforms
-since time immemorial.
+since time immemorial. It is likely to be retired, once the ``poll`` and
+``selectbis`` I/O managers are mature enough to cover all use cases.
Timer resolution: on 64bit platforms it supports microsecond precision timers
while on 32bit platforms it only supports millisecond precision. Timer accuracy
@@ -1485,6 +1501,29 @@ support 1024 open files. More specifically it supports file descriptors with
numerical value up to 1024 but no higher. It will terminate the RTS (and thus
typically the process) if this limit is exceeded.
+The ``selectbis`` I/O manager
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This I/O manager based on the classic Posix ``select()`` API. It supports
+waiting on I/O readiness on non-blocking file descriptors (i.e. not disk files).
+It is implemented within the RTS and is currently available only in the
+non-threaded RTS.
+
+It scales poorly for I/O readiness notification: costing O(n) in the number of
+threads that are waiting on I/O simultaneously. It scales well for timers:
+most timer operations cost O(log n) in the number of simultaneous timers. This
+is because it uses a heap data structure for timers.
+
+Timer resolution: this I/O manager supports microsecond precision timers.
+
+Limitation: on most platforms where it is available this I/O manager can only
+support 1024 open files. More specifically it supports file descriptors with
+numerical value up to 1024 but no higher. It will throw an IO exception if this
+limit is exceeded.
+
+This I/O manager exists primarily to support macOS, due to ``poll()`` not
+working properly on macOS, while ``select()`` does work. It's name reflects
+the fact that it is the second I/O manager to be based on ``select()``.
+
The ``poll`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1512,6 +1551,10 @@ limit can be adjusted using OS facilities (e.g. the ``ulimit`` command).
Exceeding this limit will cause the RTS (and thus typically the process) to
terminate.
+This I/O manager is not available on macOS due to the ``poll()`` API not
+working for all file types on macOS. Specifically the macOS man page for
+``poll`` documents that it does not work for device files.
+
The ``mio`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~
This I/O manager is based on several platform-specific APIs. It supports
=====================================
libraries/base/src/GHC/RTS/Flags.hs
=====================================
@@ -393,10 +393,11 @@ internal_to_base_MiscFlags i@Internal.MiscFlags{..} =
internal_to_base_ioManager Internal.IoManagerFlagAuto = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagSelect = IoManagerFlagSelect
#if __GLASGOW_HASKELL__ >= 1000
+ internal_to_base_ioManager Internal.IoManagerFlagSelectBis = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagPoll = IoManagerFlagAuto
- -- This is a lie, we cannot translate poll. We cannot translate
- -- accurately because want to freeze the API of the the compat RTS flags
- -- here. Using "auto" is the least bad translation.
+ -- This is a lie, we cannot translate these new I/O managers. We cannot
+ -- translate accurately because want to freeze the API of the the compat
+ -- RTS flags here. Using "auto" is the least bad translation.
-- https://github.com/haskell/core-libraries-committee/issues/362
#endif
internal_to_base_ioManager Internal.IoManagerFlagMIO = IoManagerFlagMIO
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
=====================================
@@ -182,6 +182,7 @@ data MiscFlags = MiscFlags
data IoManagerFlag =
IoManagerFlagAuto
| IoManagerFlagSelect -- ^ Unix only, non-threaded RTS only
+ | IoManagerFlagSelectBis -- ^ Unix only, non-threaded RTS only
| IoManagerFlagPoll -- ^ Unix only, non-threaded RTS only
| IoManagerFlagMIO -- ^ cross-platform, threaded RTS only
| IoManagerFlagWinIO -- ^ Windows only
=====================================
rts/IOManager.c
=====================================
@@ -33,6 +33,11 @@
#include "posix/Signals.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include "posix/SelectBis.h"
+#include "posix/Timeout.h"
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
#include "posix/Poll.h"
#include "posix/Timeout.h"
@@ -117,6 +122,14 @@ parseIOManagerFlag(const char *iomgrstr, IO_MANAGER_FLAG *flag)
return IOManagerAvailable;
#else
return IOManagerUnavailable;
+#endif
+ }
+ else if (strcmp("selectbis", iomgrstr) == 0) {
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ *flag = IO_MNGR_FLAG_SELECTBIS;
+ return IOManagerAvailable;
+#else
+ return IOManagerUnavailable;
#endif
}
else if (strcmp("poll", iomgrstr) == 0) {
@@ -226,6 +239,8 @@ void selectIOManager(void)
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
iomgr_type = IO_MANAGER_SELECT;
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ iomgr_type = IO_MANAGER_SELECTBIS;
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
iomgr_type = IO_MANAGER_POLL;
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -244,6 +259,12 @@ void selectIOManager(void)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MNGR_FLAG_SELECTBIS:
+ iomgr_type = IO_MANAGER_SELECTBIS;
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MNGR_FLAG_POLL:
iomgr_type = IO_MANAGER_POLL;
@@ -291,6 +312,10 @@ char * showIOManager(void)
case IO_MANAGER_SELECT:
return "select";
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return "selectbis";
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return "poll";
@@ -347,6 +372,12 @@ void initCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ initCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
initCapabilityIOManagerPoll(iomgr);
@@ -380,6 +411,12 @@ void freeCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ freeCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
freeCapabilityIOManagerPoll(iomgr);
@@ -464,6 +501,7 @@ restartIOManager(CapIOManager *iomgr, Capability **pcap)
break;
#endif
/* The IO_MANAGER_SELECT needs no initialisation */
+ /* The IO_MANAGER_SELECTBIS needs no initialisation */
/* The IO_MANAGER_POLL needs no initialisation */
/* No impl for any of the Windows I/O managers, since no forking. */
@@ -555,8 +593,14 @@ void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
markClosureTable(evac, user, &iomgr->aiop_table);
evac(user, (StgClosure **)(void *)&iomgr->timeout_queue);
break;
@@ -600,6 +644,11 @@ bool anyPendingTimeoutsOrIO(CapIOManager *iomgr)
|| (iomgr->sleeping_queue != END_TSO_QUEUE);
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return anyPendingTimeoutsOrIOSelectBis(iomgr);
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return anyPendingTimeoutsOrIOPoll(iomgr);
@@ -659,6 +708,12 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ pollCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
pollCompletedTimeoutsOrIOPoll(iomgr);
@@ -685,6 +740,7 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
{
debugTrace(DEBUG_iomanager, "waiting for completed IO or timeouts");
+ ASSERT(emptyRunQueue(iomgr->cap));
bool completed = true; // wait completed or interrupted?
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
@@ -693,6 +749,12 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ completed = awaitCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
completed = awaitCompletedTimeoutsOrIOPoll(iomgr);
@@ -734,6 +796,12 @@ void interruptIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ interruptIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
interruptIOManagerPoll(iomgr);
@@ -761,10 +829,10 @@ void interruptIOManager(CapIOManager *iomgr)
/* CMM primop. Result is true on success, or false on allocation failure. */
-IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
- StgTSO *tso,
- IOReadOrWrite rw,
- HsInt fd)
+IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
+ StgTSO *tso,
+ enum IOReadOrWrite rw,
+ HsInt fd)
{
debugTrace(DEBUG_iomanager,
"thread %ld waiting for %s I/O readiness on fd %d",
@@ -783,6 +851,10 @@ IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
return IOSubmitResultAsyncContinue;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return syncIOWaitReadySelectBis(iomgr, tso, rw, fd);
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return syncIOWaitReadyPoll(iomgr, tso, rw, fd);
@@ -803,6 +875,13 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso)
&iomgr->blocked_queue_hd,
&iomgr->blocked_queue_tl,
tso);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+ break;
+#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ syncIOCancelSelectBis(iomgr, tso);
break;
#endif
#if defined(IOMGR_ENABLED_POLL)
@@ -817,11 +896,14 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso)
&iomgr->blocked_queue_tl,
tso);
abandonWorkRequest(tso->block_info.async_reqID);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
break;
#endif
default:
barf("syncIOCancel not supported for I/O manager %d", iomgr_type);
}
+ ASSERT(tso->why_blocked == NotBlocked);
}
@@ -848,8 +930,14 @@ bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
return true;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
return syncDelayTimeout(iomgr, tso, us_delay);
#endif
#if defined(IOMGR_ENABLED_WIN32_LEGACY)
@@ -883,10 +971,18 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso)
case IO_MANAGER_SELECT:
ASSERT(tso->why_blocked == (BlockedOnDelay | BlockInfoForceNonClosure));
removeThreadFromQueue(iomgr->cap, &iomgr->sleeping_queue, tso);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
syncDelayCancelTimeout(iomgr, tso);
break;
#endif
@@ -900,6 +996,7 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso)
default:
barf("syncDelayCancel not supported for I/O manager %d", iomgr_type);
}
+ ASSERT(tso->why_blocked == NotBlocked);
}
=====================================
rts/IOManager.h
=====================================
@@ -53,6 +53,9 @@ extern bool rts_IOManagerIsWin32Native;
#if defined(IOMGR_BUILD_SELECT) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_SELECT
#endif
+#if defined(IOMGR_BUILD_SELECTBIS) && !defined(THREADED_RTS)
+ #define IOMGR_ENABLED_SELECTBIS
+#endif
#if defined(IOMGR_BUILD_POLL) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_POLL
#endif
@@ -95,6 +98,8 @@ extern bool rts_IOManagerIsWin32Native;
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
#define IOMGR_DEFAULT_STR "select"
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ #define IOMGR_DEFAULT_STR "selectbis"
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
#define IOMGR_DEFAULT_STR "poll"
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -115,6 +120,11 @@ extern bool rts_IOManagerIsWin32Native;
#else
#define IOMGR_ENABLED_STR_SELECT ""
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ #define IOMGR_ENABLED_STR_SELECTBIS " selectbis"
+#else
+ #define IOMGR_ENABLED_STR_SELECTBIS ""
+#endif
#if defined(IOMGR_ENABLED_POLL)
#define IOMGR_ENABLED_STR_POLL " poll"
#else
@@ -137,6 +147,7 @@ extern bool rts_IOManagerIsWin32Native;
#endif
#define IOMGRS_ENABLED_STR \
IOMGR_ENABLED_STR_SELECT \
+ IOMGR_ENABLED_STR_SELECTBIS \
IOMGR_ENABLED_STR_POLL \
IOMGR_ENABLED_STR_MIO \
IOMGR_ENABLED_STR_WINIO \
@@ -150,6 +161,9 @@ typedef enum {
#if defined(IOMGR_ENABLED_SELECT)
IO_MANAGER_SELECT,
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ IO_MANAGER_SELECTBIS,
+#endif
#if defined(IOMGR_ENABLED_POLL)
IO_MANAGER_POLL,
#endif
@@ -212,7 +226,19 @@ char * showIOManager(void);
*/
bool is_io_mng_native_p (void);
+/* Values for StgAsyncIOOp.operation.
+ *
+ * Note: this is encoded in 6 bits in StgAsyncIOOp.
+ */
+enum IOOpCode {
+ IOOpCodeWaitRead = 0,
+ IOOpCodeWaitWrite = 1
+ /* This will be extended, e.g. for Read/Write */
+};
+
/* Values for StgAsyncIOOp.outcome.
+ *
+ * Note: this is encoded in 2 bits in StgAsyncIOOp.
*/
enum IOOpOutcome {
IOOpOutcomeInFlight = 0,
@@ -314,7 +340,17 @@ void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr);
/* Several code paths are almost identical between read and write paths. In
* such cases we use a shared code path with an enum to say which we're doing.
*/
-typedef enum { IORead = 0, IOWrite = 1 } IOReadOrWrite;
+enum IOReadOrWrite { IORead = 0, IOWrite = 1 };
+
+INLINE_HEADER enum IOOpCode convIOReadOrWriteToIOOpCode (enum IOReadOrWrite rw)
+{
+ // The codes are compatible:
+ ASSERT((int) IOOpCodeWaitRead == (int) IORead &&
+ (int) IOOpCodeWaitWrite == (int) IOWrite);
+
+ return (enum IOOpCode) rw;
+}
+
/* Synchronous operations: I/O and delays. As synchronous operations they
* necessarily operate on threads. The thread is suspended until the operation
@@ -351,13 +387,16 @@ enum IOSubmitResultCodes {
};
/* Called from CMM primop */
-IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd);
+IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd);
+/* Cancel the I/O the TSO is blocked on and add the TSO to the run queue */
void syncIOCancel(CapIOManager *iomgr, StgTSO *tso);
/* Called from CMM primop */
bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay);
+/* Cancel the timeout the TSO is blocked on and add the TSO to the run queue */
void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso);
#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_WIN32_LEGACY)
@@ -390,6 +429,11 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr);
* does complete (or we get a signal with a handler) and process the
* completions as appropriate.
*
+ * This should _only_ be called when there are no runnable threads and it is
+ * thus accepable to block and wait for I/O or timeouts. Notably this means it
+ * must _not_ be used in the threaded RTS (where it is unacceptable to block
+ * a capability).
+ *
* Upon returning true this guarantees that the scheduler run queue is
* non-empty or that the scheduler is no longer in the running state.
* Succinctly, the post-condition in the return true case is
=====================================
rts/IOManagerInternals.h
=====================================
@@ -14,12 +14,20 @@
#include "IOManager.h"
-#if defined(IOMGR_ENABLED_POLL)
-#include <poll.h> /* for struct pollfd */
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#include "ClosureTable.h"
#include "TimeoutQueue.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include <sys/select.h> /* for fd_set */
+#endif
+
+#if defined(IOMGR_ENABLED_POLL)
+#include <poll.h> /* for struct pollfd */
+#endif
+
#include "BeginPrivate.h"
/* The per-capability data structures belonging to the I/O manager.
@@ -46,19 +54,26 @@ struct _CapIOManager {
StgTSO *sleeping_queue;
#endif
-#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECT) \
+ || defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#if defined(HAVE_PREEMPTION)
/* FDs for waking up the I/O manager when it is blocked waiting */
int interrupt_fd_r, interrupt_fd_w;
#endif
#endif
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_POLL) \
+ || defined(IOMGR_ENABLED_SELECTBIS)
/* AIOP and timeout collections shared by several I/O manager impls */
ClosureTable aiop_table;
StgTimeoutQueue *timeout_queue;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ fd_set *rfds, *wfds;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
/* Auxiliary table with size and indexes matching the aiop_table. This is
* aliased to the tail of the full poll table, which has a head entry for
=====================================
rts/RaiseAsync.c
=====================================
@@ -28,7 +28,7 @@
static void blockedThrowTo (Capability *cap,
StgTSO *target, MessageThrowTo *msg);
-static void removeFromQueues(Capability *cap, StgTSO *tso);
+static void unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso);
static void removeFromMVarBlockedQueue (StgTSO *tso);
@@ -62,8 +62,10 @@ throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception,
return;
}
- // Remove it from any blocking queues
- removeFromQueues(cap,tso);
+ // Remove it from any blocking queues and add it to the run queue
+ unblockAndAppendToRunQueue(cap,tso);
+ ASSERT(tso->why_blocked == NotBlocked ||
+ tso->why_blocked == ThreadMigrating);
raiseAsync(cap, tso, exception, stop_at_atomically, stop_here);
}
@@ -471,7 +473,7 @@ check_target:
blockedThrowTo(cap,target,msg);
return THROWTO_BLOCKED;
} else {
- removeFromQueues(cap,target);
+ unblockAndAppendToRunQueue(cap,target);
raiseAsync(cap, target, msg->exception, false, NULL);
return THROWTO_SUCCESS;
}
@@ -612,16 +614,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso)
tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
}
-/* -----------------------------------------------------------------------------
- Remove a thread from blocking queues.
-
- This is for use when we raise an exception in another thread, which
- may be blocked.
-
- Precondition: we have exclusive access to the TSO, via the same set
- of conditions as throwToSingleThreaded() (c.f.).
- -------------------------------------------------------------------------- */
-
+// Helper for unblockAndAppendToRunQueue
static void
removeFromMVarBlockedQueue (StgTSO *tso)
{
@@ -664,13 +657,24 @@ removeFromMVarBlockedQueue (StgTSO *tso)
tso->_link = END_TSO_QUEUE;
}
+/* -----------------------------------------------------------------------------
+ Remove a thread from blocking queues (if any) and add it to the run queue
+ (if it wasn't on the run queue already).
+
+ This is for use when we raise an exception in another thread, which
+ may be blocked.
+
+ Precondition: we have exclusive access to the TSO, via the same set
+ of conditions as throwToSingleThreaded() (c.f.).
+ -------------------------------------------------------------------------- */
+
static void
-removeFromQueues(Capability *cap, StgTSO *tso)
+unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso)
{
switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
- case NotBlocked:
- case ThreadMigrating:
+ case NotBlocked: // Already on the run queue
+ case ThreadMigrating: // Not added to the run queue
return;
case BlockedOnSTM:
@@ -680,16 +684,16 @@ removeFromQueues(Capability *cap, StgTSO *tso)
// perhaps have a debugging test to make sure that this really
// happens and that the 'zombie' transaction does not get
// committed.
- goto done;
+ break;
case BlockedOnMVar:
case BlockedOnMVarRead:
removeFromMVarBlockedQueue(tso);
- goto done;
+ break;
case BlockedOnBlackHole:
// nothing to do
- goto done;
+ break;
case BlockedOnMsgThrowTo:
{
@@ -709,18 +713,19 @@ removeFromQueues(Capability *cap, StgTSO *tso)
case BlockedOnDoProc:
// These blocking reasons are only used by some I/O managers
syncIOCancel(cap->iomgr, tso);
- goto done;
+ return;
case BlockedOnDelay:
// This blocking reasons is only used by some I/O managers
syncDelayCancel(cap->iomgr, tso);
- goto done;
+ return;
default:
- barf("removeFromQueues: %d", tso->why_blocked);
+ barf("unblockAndAppendToRunQueue: %d", tso->why_blocked);
}
- done:
+ // The cases above that use return add the TSO to the run queue themselves
+ // (or don't need to). For the rest (that use break) we do it here.
appendToRunQueue(cap, tso);
RELEASE_STORE(&tso->why_blocked, NotBlocked);
}
=====================================
rts/configure.ac
=====================================
@@ -368,6 +368,15 @@ GHC_IOMANAGER_ENABLE([select], [EnableIOManagerSelect], [IOMGR_BUILD_SELECT],
[AC_MSG_ERROR([sys/select.h required by select I/O manager])],[])
fi])
+GHC_IOMANAGER_ENABLE([selectbis], [EnableIOManagerSelectBis], [IOMGR_BUILD_SELECTBIS],
+ [if test "$HostOS" = "mingw32"; then
+ EnableIOManagerSelectBis=NO
+ else
+ AC_CHECK_HEADER([sys/select.h],
+ [EnableIOManagerSelectBis=YES],
+ [AC_MSG_ERROR([sys/select.h required by selectbis I/O manager])],[])
+ fi])
+
GHC_IOMANAGER_ENABLE([poll], [EnableIOManagerPoll], [IOMGR_BUILD_POLL],
[if test "$HostOS" = "mingw32"; then
EnableIOManagerPoll=NO
@@ -407,6 +416,7 @@ if test "$HostOS" = "mingw32"; then
else
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [select], [EnableIOManagerSelect])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [poll], [EnableIOManagerPoll])
+ GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [selectbis], [EnableIOManagerSelectBis])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerThreadedDefault], [mio], [EnableIOManagerMIO])
fi
GHC_IOMANAGER_DEFAULT_CHECK_NOT_EMPTY([IOManagerNonThreadedDefault],[non-threaded])
@@ -419,6 +429,9 @@ dnl Now define CPP vars for the default ones (threaded and non-threaded)
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[select], [IOMGR_DEFAULT_NON_THREADED_SELECT])
+GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
+ [selectbis], [IOMGR_DEFAULT_NON_THREADED_SELECTBIS])
+
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[poll], [IOMGR_DEFAULT_NON_THREADED_POLL])
=====================================
rts/include/rts/Flags.h
=====================================
@@ -258,6 +258,7 @@ typedef enum _IO_MANAGER_FLAG {
/* All other choices pick only the requested one, with no fallback. */
IO_MNGR_FLAG_SELECT, /* Unix only, non-threaded RTS only */
+ IO_MNGR_FLAG_SELECTBIS, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_POLL, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_MIO, /* cross-platform, threaded RTS only */
IO_MNGR_FLAG_WINIO, /* Windows only */
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -823,6 +823,8 @@ typedef struct {
// In the threaded way there is one I/O manager per capability. We have
// to handle cross-capability I/O op cancellation specially, so we need
// to know which capability an aiop is being managed on.
+ //
+ // We could probably afford to steal some bits here if needed.
uint16_t capno;
// This tells us which thing the notify union above contains. It is a
@@ -837,7 +839,30 @@ typedef struct {
// 3: IOOpOutcomeCancelled: cancelled, no further detail.
uint16_t outcome: 2;
- // 12 bits going spare!
+ // The I/O operation we are performing. It is a value from enum IOOpCode,
+ // but we don't use the enum type here due to portability concerns for
+ // this C bitfield.
+ //
+ // The size of this field, allows us up to 64 opcodes.
+ uint16_t operation: 6;
+
+ // 6 bits going spare!
+ uint16_t padding: 6;
+
+ // The file descriptor the operation is on. This is used in several I/O
+ // managers to group StgAsyncIOOps by fd. In particular this is needed
+ // for cancelling all wait-notification ops when closing an fd. It is
+ // also handy for logging and debugging.
+ //
+ // Note that it is technically possible to stuff Win32 HANDLEs into here,
+ // but no Win32 I/O manager does this _yet_. See:
+ // https://learn.microsoft.com/en-us/windows/win32/winprog64/interprocess-comm…
+ // > 64-bit versions of Windows use 32-bit handles for interoperability.
+ // > When sharing a handle between 32-bit and 64-bit applications, only
+ // > the lower 32 bits are significant, so it is safe to truncate the
+ // > handle (when passing it from 64-bit to 32-bit) or sign-extend the
+ // > handle (when passing it from 32-bit to 64-bit).
+ uint32_t fd;
union {
// For successful outcomes, this is the result code of the operation.
@@ -850,10 +875,6 @@ typedef struct {
uint32_t error;
};
- // Round it up to 2 words on 64bit platforms.
- // This is also space for future extension, without increasing the size.
- uint32_t padding;
-
// Note that because we use fixed size Ctypes here then the size in words
// of this heap object is different on 32bit and 64bit platforms.
// We handle this in the INFO_TABLE_CONSTR decl for stg_ASYNCIOOP using
=====================================
rts/posix/Poll.c
=====================================
@@ -132,7 +132,7 @@ the aiop_table, but still allows the full_poll_table to have an extra entry.
/* Forward declarations */
static bool enlargeTables(CapIOManager *iomgr);
static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void removeFromTables(CapIOManager *iomgr, int i);
static void reportPollError(int res, nfds_t nfds) STG_NORETURN;
@@ -172,7 +172,7 @@ void freeCapabilityIOManagerPoll(CapIOManager *iomgr)
/* Used to implement syncIOWaitReady. */
IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
- IOReadOrWrite rw, HsInt fd)
+ enum IOReadOrWrite rw, HsInt fd)
{
StgAsyncIOOp *aiop;
aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
@@ -188,7 +188,7 @@ IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
}
IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
- IOReadOrWrite rw, int fd)
+ enum IOReadOrWrite rw, int fd)
{
if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
bool ok = enlargeTables(iomgr);
@@ -203,9 +203,11 @@ IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
/* The syncIO wrapper or CMM primop filled in the notify and live fields,
* we fill the rest.
*/
- aiop->capno = iomgr->cap->no;
- aiop->index = ix;
- aiop->outcome = IOOpOutcomeInFlight;
+ aiop->capno = iomgr->cap->no;
+ aiop->index = ix;
+ aiop->outcome = IOOpOutcomeInFlight;
+ aiop->operation = convIOReadOrWriteToIOOpCode(rw);
+ aiop->fd = fd;
/* Fill in the corresponding entry in the aiop_poll_table */
iomgr->aiop_poll_table[ix] = (struct pollfd) {
@@ -222,20 +224,7 @@ void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso)
StgAsyncIOOp *aiop = tso->block_info.aiop;
ASSERT(aiop->notify_type == NotifyTSO);
ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
- ioCancel(iomgr, aiop);
- setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
- /* We cannot use the normal notifyIOCompletion here. We are in the context
- * of throwTo, interrupting a thread blocked on IO via an async exception.
- * We don't put the TSO back on the run queue or change the why_blocked
- * status, as that is done by removeFromQueues (in the throwTo* functions).
- */
-
- /* We are in the TSO case, where the aiop was only reachable from the TSO
- * itself, and thus it is now no longer be reachable at all.
- */
- IF_NONMOVING_WRITE_BARRIER_ENABLED {
- updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
- }
+ asyncIOCancelPoll(iomgr, aiop);
}
@@ -246,29 +235,14 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop)
* because each aiop is GC heap allocated, so cannot be recycled until it
* is no longer retained by the application.
*/
- ASSERT(aiop->notify_type != NotifyTSO);
if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
- ioCancel(iomgr, aiop);
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
notifyIOCompletion(iomgr, aiop);
}
}
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop)
-{
- int ix = aiop->index;
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
- }
- aiop->outcome = IOOpOutcomeCancelled;
-}
-
-
bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr)
{
return !isEmptyTimeoutQueue(iomgr->timeout_queue)
@@ -313,6 +287,15 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
}
+/* Called from poll/awaitCompletedTimeoutsOrIOPoll after a successful poll()
+ * call to process all the I/O completions.
+ *
+ * We match up the I/O completion notifications from the system call against
+ * the pending I/O operations from the aiop_table, and use notifyIOCompletion
+ * on each completed aiop.
+ *
+ * Returns true if the poll() was interupted via iomgr->interrupt_fd_r.
+ */
static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
{
/* The scheme we use with poll is that we have a dense poll table, and a
@@ -323,6 +306,7 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
*/
debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
ncompletions);
+ ASSERT(ncompletions > 0);
bool interrupt = false;
#if defined(HAVE_PREEMPTION)
@@ -337,9 +321,8 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
#endif
struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
- int n = ncompletions;
int i = 0;
- while (n > 0) {
+ while (ncompletions > 0) {
ASSERT(i < sizeClosureTable(&iomgr->aiop_table));
/* Since each aiop_table entry is for a single (fd, rw) pair, we
@@ -349,6 +332,8 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
if (aiop_poll_table[i].revents) {
StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ ASSERT(aiop->outcome == IOOpOutcomeInFlight);
+
/* We do need to handle POLLNVAL, but we do not need to do anything
* special for POLLERR or POLLHUP. (See man poll for details).
* The calling thread will typically try to do I/O after waiting
@@ -364,26 +349,14 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
aiop->result = 0;
}
- /* Remove from the completion table, preserving compactness, and
- * apply the same compacting to the aiop_poll_table.
- */
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, i,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to;
- aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- aiop_poll_table[ix_to] = aiop_poll_table[ix_from];
- }
-
+ removeFromTables(iomgr, i);
notifyIOCompletion(iomgr, aiop);
- n--;
+ ncompletions--;
} else {
- /* You'd expect incrementing the poll table index to be
- * unconditional, but we don't increment the index if we did
- * process the entry, because using removeCompactClosureTable
- * means we'll move an entry from the end into the same index.
+ /* You'd expect incrementing the table index to be unconditional,
+ * but we don't increment the index if we did process the entry,
+ * because using removeFromTables means we'll move an entry from
+ * the end of the table into the index i.
*/
i++;
}
@@ -564,6 +537,7 @@ bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
return !interrupt;
}
+
static void reportPollError(int res, nfds_t nfds)
{
if (errno == EINVAL) {
@@ -619,4 +593,20 @@ static bool enlargeTables(CapIOManager *iomgr)
return true;
}
+
+/* Remove from the completion table, preserving compactness, and apply the same
+ * compacting to the aiop_poll_table.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
+ }
+}
+
#endif /* IOMGR_ENABLED_POLL */
=====================================
rts/posix/Poll.h
=====================================
@@ -21,12 +21,12 @@ void freeCapabilityIOManagerPoll(CapIOManager *iomgr);
/* Synchronous I/O and timer operations */
IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
- IOReadOrWrite rw, HsInt fd);
+ enum IOReadOrWrite rw, HsInt fd);
void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso);
/* Asynchronous operations */
IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
- IOReadOrWrite rw, int fd);
+ enum IOReadOrWrite rw, int fd);
void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop);
/* Scheduler operations */
=====================================
rts/posix/SelectBis.c
=====================================
@@ -0,0 +1,654 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * See SelectBis.h for the sad story of why this exists.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "rts/PosixSource.h"
+#include "Rts.h"
+#include "RtsFlags.h" // needed by SET_HDR macro
+
+#include "IOManager.h" // defines IOMGR_ENABLED_SELECTBIS
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+#include "Capability.h"
+#include "Threads.h"
+#include "Schedule.h"
+#include "Prelude.h"
+#include "RtsUtils.h"
+#include "rts/Time.h"
+#include "Trace.h"
+
+#include "SelectBis.h"
+#include "RtsSignals.h"
+
+#include <errno.h>
+#include <sys/select.h>
+
+#include "IOManagerInternals.h"
+#include "Timeout.h"
+#include "FdWakeup.h"
+
+/******************************************************************************
+
+This I/O manager is based on the classic Unix select() system call.
+
+ int select(int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, struct timeval *timeout);
+
+The select() call has various limits, quirks and slight differences between
+historical Unix variants.
+
+The basic idea is to collect a set of fds (represented as a bitset) that we are
+interested in: one for reads, one for writes. The call then queries for I/O
+readiness on all the fds in the read and write sets. The result is a set of fds
+that are ready to read from, and a set that are ready to write to. The same
+bitset representation is used for the output. Indeed a "fun" quirk of select()
+is that it mutates the fd sets it is passed, which means they either need to be
+built up each time, or copied. There is also an optional timeout if no fds are
+ready immediately. There is also an fd bitset for "exceptional conditions"
+which we do not use.
+
+There is of course no incremental behaviour here; this is a bulk one-off call
+with no persistent state. This has obvious scaling problems. The cost each time
+is O(n) in the maximum of the integer value of the fds of interest. There is
+also a maximum bitset size. On Linux this is 1024. This means select() cannot
+be used if the process uses more than that many open files, even if we're only
+interested in a few. On OSX the default limit is also 1024 but this can be
+raised or even managed dynamically, at the cost of more memory (and some
+non-standard code).
+
+That particular problem is solved by the later Unix poll() system call, which
+uses an array of the fds we are interested in, which means it is not limited by
+the absolute value of the fds numbers (but it is still O(n) in how many fds we
+are interested in).
+
+We have some choice in how we process results. We want to find the intersection
+between the requests for notification of I/O readiness (coming from the Haskell
+threads) and the read and write bit sets. There's not much clever we can do to
+compute this intersection efficiently: we can either iterate over the bit sets
+or over the readiness requests. There is no obvious answer here. Typically
+there will be few results compared to the number of requests and a bitset scan
+could be fast. In practice we cannot portably scan the bitset efficiently (e.g.
+word at a time). Portably, we can only probe each bit at a time using FD_ISSET.
+Portability is the main reason to use select() rather than a more modern
+interface, so we have to take it seriously here. Furthermore, if we iterated
+over the bit sets we would have to maintain a mapping from fd to requests.
+
+In principle we also have the choice to maintain the read and write fd bit sets
+incrementally, or create them afresh each time we call select(). There is no
+asymptotic bonus to maintaining them incrementally since the whole thing is
+O(n) anyway. There could plausibly be some constant factor benefit. To maintain
+the fd bit sets incrementally we would need to maintain a mapping between
+requests and fds. This would also be an extra cost that would have to be
+outweighed by any saving.
+
+In the end we take the simple approach to constructing the bitset inputs and to
+results processing. We create the bit sets afresh each time from the collection
+of requests. For processing results we iterate over the requests and look up
+each one to see if it is in the appropriate result bitset. Along with each
+operation, we store the fd and whether we were interested in reading or writing.
+We iterate over the operations and use the fd and r/w information to construct
+the read and write bit sets.
+
+A particularly frustrating feature of select() is that if any single fd in any
+fd bitset is invalid (e.g. because the file was already closed) then select()
+fails and tells us there is a bad fd somewhere, but it has no way to indicate
+which fd was bad. This is really quite annoying as we then have to do a search
+through the fds to find which one was bad.
+
+The primary data structure for this I/O manager is a aiop_table which is a
+ClosureTable of AsyncIOOps. This table tracks the active I/O operations, with
+one entry per operation (corresponding to threads calling waitRead#/waitWrite#).
+We also track the fd for each operation and whether the operation is waiting on
+read or write readiness. This additional information is stored in the fd_table.
+The fd_table is maintained as an auxiliary table to the aiop_table, with table
+indexes matching the ClosureTable. So there is an entry in the aiop_table for
+each operation, and a corresponding entry in the fd_table at the same table
+index. The aiop_table and the fd_table are maintained incrementally, and with
+dense indexes.
+
+We also use a StgTimeoutQueue to track timeouts, and use the delay to the next
+timeout (if any) as the poll() timeout parameter.
+
+The CapIOManager structure for this I/O manager contains:
+
+ ClosureTable aiop_table;
+ StgTimeoutQueue *timeout_queue;
+ int interrupt_fd_r, interrupt_fd_w;
+
+******************************************************************************/
+
+/* Forward declarations */
+static bool enlargeTables(CapIOManager *iomgr);
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void removeFromTables(CapIOManager *iomgr, int i);
+static bool fdInSelectRange(int fd);
+static int collectFdSets(CapIOManager *iomgr);
+static void processBadFds(CapIOManager *iomgr);
+static void reportSelectError(void) STG_NORETURN;
+
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ initClosureTable(&iomgr->aiop_table, ClosureTableCompact);
+ iomgr->timeout_queue = emptyTimeoutQueue();
+
+#if defined(HAVE_PREEMPTION)
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+
+ /* Would never happen in a standalone process, but could plausibly happen
+ * if the RTS is used within another process that already has many open fds.
+ */
+ if (iomgr->interrupt_fd_r < 0 || iomgr->interrupt_fd_r >= (int)FD_SETSIZE ||
+ iomgr->interrupt_fd_w < 0 || iomgr->interrupt_fd_w >= (int)FD_SETSIZE) {
+ barf("initCapabilityIOManagerSelectBis: fds out of select range");
+ }
+#endif
+
+ iomgr->rfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+ iomgr->wfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+}
+
+
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ stgFree(iomgr->rfds);
+ stgFree(iomgr->wfds);
+#if defined(HAVE_PREEMPTION)
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Used to implement syncIOWaitReady. */
+IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd)
+{
+ StgAsyncIOOp *aiop;
+ aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
+ if (RTS_UNLIKELY(aiop == NULL)) return IOSubmitResultHeapOverflow;
+ SET_HDR(aiop, &stg_ASYNCIOOP_info, iomgr->cap->r.rCCCS);
+ aiop->notify.tso = tso;
+ aiop->notify_type = NotifyTSO;
+ aiop->live = &stg_ASYNCIO_LIVE0_closure;
+ tso->block_info.aiop = aiop;
+ RELEASE_STORE(&tso->why_blocked, rw == IORead ? BlockedOnRead
+ : BlockedOnWrite);
+ return asyncIOWaitReadySelectBis(iomgr, aiop, rw, fd);
+}
+
+IOSubmitResult asyncIOWaitReadySelectBis(CapIOManager *iomgr,
+ StgAsyncIOOp *aiop,
+ enum IOReadOrWrite rw, int fd)
+{
+ if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
+ bool ok = enlargeTables(iomgr);
+ if (RTS_UNLIKELY(!ok)) return IOSubmitResultHeapOverflow;
+ }
+
+ if (RTS_UNLIKELY(!fdInSelectRange(fd))) {
+ /* Synchronous error */
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ return -EBADF;
+ };
+
+ int ix = insertClosureTable(iomgr->cap, &iomgr->aiop_table, aiop);
+
+ /* We use the aiop_table densely. */
+ ASSERT(ix == sizeClosureTable(&iomgr->aiop_table) - 1);
+
+ /* The syncIO wrapper or CMM primop filled in the notify and live fields,
+ * we fill the rest.
+ */
+ aiop->capno = iomgr->cap->no;
+ aiop->index = ix;
+ aiop->outcome = IOOpOutcomeInFlight;
+ aiop->operation = convIOReadOrWriteToIOOpCode(rw);
+ aiop->fd = fd;
+
+ return IOSubmitResultAsyncContinue;
+}
+
+
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso)
+{
+ StgAsyncIOOp *aiop = tso->block_info.aiop;
+ ASSERT(aiop->notify_type == NotifyTSO);
+ ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
+ asyncIOCancelSelectBis(iomgr, aiop);
+}
+
+
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ /* We can reliably determine if the aiop is still in progress by checking
+ * if the aiop_table still points to this aiop object. This is reliable
+ * because each aiop is GC heap allocated, so cannot be recycled until it
+ * is no longer retained by the application.
+ */
+ if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
+ notifyIOCompletion(iomgr, aiop);
+ }
+}
+
+
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ return !isEmptyTimeoutQueue(iomgr->timeout_queue)
+ || !isEmptyClosureTable(&iomgr->aiop_table);
+}
+
+
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ ASSERT(aiop->outcome != IOOpOutcomeInFlight);
+ switch (aiop->notify_type) {
+ case NotifyTSO:
+ {
+ /* We should be guaranteed that the tso is still on the same
+ * cap because the tso was not on the run queue of any cap and
+ * so is not subject to thread migration.
+ */
+ StgTSO *tso = aiop->notify.tso;
+ ASSERT(tso->cap == iomgr->cap);
+
+ /* Fill in the outcome and result/error on the TSO's stack frame */
+ setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
+ pushOnRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+
+ /* For the TSO case, the aiop was only reachable from the TSO
+ * itself, and thus it is now no longer be reachable at all.
+ */
+ IF_NONMOVING_WRITE_BARRIER_ENABLED {
+ updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
+ }
+ break;
+ }
+ case NotifyMVar:
+ barf("selectbis iomgr: MVar notification not yet supported");
+ break;
+
+ case NotifyTVar:
+ barf("selectbis iomgr: TVar notification not yet supported");
+ break;
+ }
+}
+
+
+/* Called from poll/awaitCompletedTimeoutsOrIOSelectBis after a successful
+ * select() call to process all the I/O completions.
+ *
+ * We match up the I/O completion notifications from the system call against
+ * the pending I/O operations from the aiop_table, and use notifyIOCompletion
+ * on each completed aiop.
+ *
+ * Returns true if the select() was interupted via iomgr->interrupt_fd_r.
+ */
+static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
+{
+ /* We want to find the intersection between the sets of ready fds returned
+ * by select() and the aiop_table. Given how select() represents
+ * things there's no particularly efficient way to do it.
+ *
+ * We just go through the whole aiop_table and look up each one in
+ * the read or write fd_set to see if they completed. Note that here is
+ * where we rely on the aiop_table being dense so we can iterate
+ * over the entries. We can short-cut if we hit the ncompletions before
+ * getting to the end of the table.
+ */
+ debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
+ ncompletions);
+ ASSERT(ncompletions > 0);
+
+ bool interrupt = false;
+#if defined(HAVE_PREEMPTION)
+ /* If the interrupt_fd_r is ready, collect it */
+ if (FD_ISSET(iomgr->interrupt_fd_r, iomgr->rfds)) {
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ ncompletions--;
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager");
+ }
+#endif
+
+ int i = 0;
+ while (ncompletions > 0) {
+ ASSERT(i < sizeClosureTable(&iomgr->aiop_table));
+
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+ ASSERT(aiop->outcome == IOOpOutcomeInFlight);
+
+ if (op == IOOpCodeWaitRead ? FD_ISSET(fd, iomgr->rfds)
+ : FD_ISSET(fd, iomgr->wfds)) {
+ aiop->outcome = IOOpOutcomeSuccess;
+ aiop->result = 0;
+ removeFromTables(iomgr, i);
+ notifyIOCompletion(iomgr, aiop);
+ ncompletions--;
+ } else {
+ /* You'd expect incrementing the table index to be unconditional,
+ * but we don't increment the index if we did process the entry,
+ * because using removeFromTables means we'll move an entry from
+ * the end of the table into the index i.
+ */
+ i++;
+ }
+ }
+ return interrupt;
+}
+
+
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+ }
+
+ if (!isEmptyClosureTable(&iomgr->aiop_table)) {
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Poll for I/O readiness, without waiting. */
+ struct timeval tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, &tv);
+ if (res == 0) {
+ /* There is no I/O ready. We'll return to the scheduler. */
+
+ } else if (res > 0) {
+ int ncompletions = res;
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1);
+ processIOCompletions(iomgr, ncompletions);
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. This is unlikely since we asked
+ * select() not to wait, but if so we'll return to the scheduler.
+ */
+
+ } else {
+ reportSelectError();
+ }
+ }
+}
+
+
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ bool interrupt = false; /* got woken up via interruptIOManager */
+
+ /* Loop until we've woken up some threads. This loop is needed because the
+ * select() timing isn't accurate, we sometimes sleep for a while but not
+ * long enough to wake up a thread in a threadDelay. Or we may need to
+ * sleep multiple times if we need to sleep longer than the maximum timeout
+ * that select() supports.
+ */
+ do {
+ /* There is either pending I/O or pending timers. */
+ ASSERT(!isEmptyTimeoutQueue(iomgr->timeout_queue) ||
+ !isEmptyClosureTable(&iomgr->aiop_table));
+
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+
+ /* If we didn't wake any threads due to expiring timeouts, then we need
+ * to wait on I/O. Or to put it another way, even if we did wake some
+ * threads, we'll still poll (but not wait) for I/O. This is to ensure
+ * we avoid starving threads blocked on I/O.
+ */
+ bool wait = emptyRunQueue(iomgr->cap);
+
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Decide if we are going to wait if no I/O is ready, either:
+ * poll only, wait indefinitely, or wait until a timeout.
+ */
+ struct timeval tv, *timeout_us;
+ timeout_us = timeoutInMicroseconds(iomgr, wait, now, &tv);
+
+ /* Check for I/O readiness, possibly waiting. */
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, timeout_us);
+
+ if (res == 0) {
+ /* Success but there is no I/O ready. This can happen either if we
+ * were not blocking or were in a timed wait and the timeout
+ * occurred before any I/O became ready. Either way, the do-while
+ * loop condition will handle it.
+ */
+ ASSERT(timeout_us != NULL);
+
+ } else if (res > 0) {
+ int ncompletions = res;
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1);
+ interrupt = processIOCompletions(iomgr, ncompletions);
+ // FIXME: do we also need to check for timeout completions now?
+ // we have a non-empty queue, but if !wait then we have also moved
+ // on and so we sould check for timeouts.
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. In the non-threaded RTS, if the
+ * signal is one of ours we need to return to the scheduler to let
+ * it handle it. Otherwise we would loop and keep waiting for I/O
+ * or timeouts, meaning we would block for a long time before the
+ * signal is serviced.
+ */
+#if defined(RTS_USER_SIGNALS)
+ if (startPendingSignalHandlers(iomgr->cap)) break;
+#endif
+
+ /* We can also be interrupted by the shutdown signal handler, which
+ * will set sched_state and so cause us to drop out of the loop.
+ *
+ * For any other interruption (e.g. timer) we will go round the
+ * do-while loop again.
+ */
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else {
+ reportSelectError();
+ }
+
+ } while (emptyRunQueue(iomgr->cap)
+ && !interrupt
+ && (getSchedState() == SCHED_RUNNING));
+ return !interrupt;
+}
+
+
+static void reportSelectError(void)
+{
+ sysErrorBelch("select() failed");
+ stg_exit(EXIT_FAILURE);
+}
+
+
+static void processBadFds(CapIOManager *iomgr)
+{
+ /* This is extremely tiresome. The select() call fails with EBADF if any
+ * fd is invalid (usually closed), but it does not tell us which one.
+ * So we have to loop through them to find the offending fd.
+ *
+ * This will only find the first bad fd, so the caller must cope with
+ * there still being bad fds after this.
+ */
+
+ fd_set rfds, wfds;
+ FD_ZERO(&rfds);
+ FD_ZERO(&wfds);
+
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+ for (int ix = 0; ix < nentries; ix++) {
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, ix);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+
+ struct timeval tv = { .tv_sec = 0, .tv_usec = 0 };
+ int res;
+ if (op == IOOpCodeWaitRead) {
+ FD_SET(fd, &rfds);
+ res = select(fd+1, &rfds, NULL, NULL, &tv);
+ FD_CLR(fd, &rfds);
+ } else {
+ FD_SET(fd, &wfds);
+ res = select(fd+1, NULL, &wfds, NULL, &tv);
+ FD_CLR(fd, &wfds);
+ }
+ if (res == 0) {
+ continue;
+
+ } else if (errno == EBADF) {
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ removeFromTables(iomgr, ix);
+ notifyIOCompletion(iomgr, aiop);
+ /* There is /probably/ only one bad fd at once, so we abort the
+ * search here. If we are unlucky and there are several bad fds
+ * then the caller will just loop round again.
+ */
+
+ return;
+
+ } else if (errno == EINTR) {
+ /* Unlikely, since we did a non-blocking select().
+ * Try again with the same ix. */
+ ix--;
+ continue;
+
+ } else {
+ reportSelectError();
+ }
+ }
+}
+
+
+void interruptIOManagerSelectBis(CapIOManager *iomgr)
+{
+#if defined(HAVE_PREEMPTION)
+ sendFdWakeup(iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Helper function to double the size of the aiop_table.
+ */
+static bool enlargeTables(CapIOManager *iomgr)
+{
+ int oldcapacity = capacityClosureTable(&iomgr->aiop_table);
+ int newcapacity = (oldcapacity == 0) ? 1 : (oldcapacity * 2);
+
+ bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity);
+ if (RTS_UNLIKELY(!ok)) return false;
+
+ return true;
+}
+
+
+/* Remove from the completion table, preserving compactness.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ }
+}
+
+/* In preparation for calling select(), set the iomgr->rfds and iomgr->wfds
+ * sets based on the pending I/O ops iomgr->aiop_table.
+ *
+ * Returns the maximum fd in the two sets (since select() needs this).
+ */
+static int collectFdSets(CapIOManager *iomgr)
+{
+ int maxfd = -1;
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+
+ /* In principle we could optimise this slightly by not resetting the
+ * whole of each fdset, by assuming that select() does not modify
+ * entries above maxfd. This is probably not worth doing however, since
+ * this I/O manager is supposed to be portable and is expected to be slow.
+ */
+ FD_ZERO(iomgr->rfds);
+ FD_ZERO(iomgr->wfds);
+
+#if defined(HAVE_PREEMPTION)
+ /* We're always interested in our interrupt fd */
+ {
+ int fd = iomgr->interrupt_fd_r;
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ FD_SET(fd, iomgr->rfds);
+ }
+#endif
+
+ for (int ix = 0; ix < nentries; ix++) {
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, ix);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+ ASSERT(fdInSelectRange(fd)); // Checked in asyncIOWaitReadySelectBis
+
+ if (op == IOOpCodeWaitRead) {
+ FD_SET(fd, iomgr->rfds);
+ } else {
+ FD_SET(fd, iomgr->wfds);
+ }
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ }
+ return maxfd;
+}
+
+
+/* Helper function to check if the fd is within range for select().
+ */
+static bool fdInSelectRange(int fd)
+{
+ /* On older FreeBSDs, FD_SETSIZE is unsigned. Cast it to signed int
+ * in order to switch off the 'comparison between signed and
+ * unsigned error message
+ * Newer versions of FreeBSD have switched to unsigned int:
+ * https://github.com/freebsd/freebsd/commit/12ae7f74a071f0439763986026525094a…
+ * http://fa.freebsd.cvs-all.narkive.com/bCWNHbaC/svn-commit-r265051-head-sys-…
+ * So the (int) cast should be removed across the code base once
+ * GHC requires a version of FreeBSD that has that change in it.
+ */
+ return ((fd >= 0) && (fd < (int)FD_SETSIZE));
+ /* TODO: on several platforms, it is possible to use a larger fd set size.
+ For example on OSX:
+ https://code.saghul.net/2016/05/libuv-internals-the-osx-select2-trick/
+ And probably similar on other platforms. It basically amounts to looking
+ through the representation abstraction of fd_set and to know that it is
+ indeed a bit set, and then we can simply allocate it and manipulte it
+ ourselves. We could do this, dynamically (re-)allocate the size.
+ */
+}
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
=====================================
rts/posix/SelectBis.h
=====================================
@@ -0,0 +1,62 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * This I/O manager is called "selectbis", because it is the second such I/O
+ * manager based on select(). The historic implementation is named "select"
+ * and lives in Select.{c,h}. This I/O manager exists for the benefit of users
+ * of Apple products.
+ *
+ * The poll I/O manger _should_ be the portable baseline posix I/O manager.
+ * Unfortunately Mac OSX has a buggy implementation of poll(). The OSX man
+ * page documents this as:
+ *
+ * > BUGS The poll() system call currently does not support devices.
+ *
+ * This is quite incredible, given that poll and select should be relatively
+ * thin interfaces to the the same underlying kernel infrastructure.
+ * Furthermore, OSX is supposedly certified as POSIX compliant! Due to this
+ * (incompetence) we need a new I/O manager implementation based on the
+ * antique select() API, with all of its known limitations.
+ *
+ * Please direct all complaints to:
+ * Apple Inc., One Apple Park Way, Cupertino, CA 95014, USA.
+ *
+ * Prototypes for functions in SelectBis.c
+ *
+ * -------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "IOManager.h"
+
+#include "BeginPrivate.h"
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+
+/* Synchronous I/O and timer operations */
+IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd);
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso);
+
+/* Asynchronous operations */
+IOSubmitResult asyncIOWaitReadySelectBis(CapIOManager *iomgr,
+ StgAsyncIOOp *aiop,
+ enum IOReadOrWrite rw, int fd);
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+
+/* Scheduler operations */
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void interruptIOManagerSelectBis(CapIOManager *iomgr);
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
+
+#include "EndPrivate.h"
+
=====================================
rts/posix/Timeout.c
=====================================
@@ -14,8 +14,9 @@
#include "Schedule.h"
#include "Prelude.h"
-#include "Timeout.h"
+#include "IOManager.h"
#include "IOManagerInternals.h"
+#include "Timeout.h"
#include "TimeoutQueue.h"
#include <limits.h>
@@ -24,7 +25,8 @@
/* Currently only used by the poll I/O manager, but in future may be used by
several in-RTS I/O managers.
*/
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
{
@@ -68,14 +70,13 @@ void syncDelayCancelTimeout(CapIOManager *iomgr, StgTSO *tso)
deleteTimeoutQueue(&iomgr->timeout_queue, timeout);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+
/* the timeout is no longer accessible from anywhere (except here) */
IF_NONMOVING_WRITE_BARRIER_ENABLED {
updateRemembSetPushClosure(iomgr->cap, (StgClosure *)timeout);
}
-
- /* We don't put the TSO back on the run queue or change the why_blocked
- status, as that is done by removeFromQueues (in the throwTo* functions).
- */
}
static void notifyTimeoutCompletion(CapIOManager *iomgr, StgTimeout *timeout);
@@ -222,5 +223,58 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
}
#endif
-#endif // defined(IOMGR_ENABLED_POLL)
+/* select() expect a timeout in microseconds, using struct timeval * with
+ * special values of NULL for indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv)
+{
+ if (!wait) {
+ /* Don't wait, just poll. */
+ *tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ return tv;
+
+ } else if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ /* SUSv2 allows implementations to have an implementation defined
+ * maximum timeout for select(2). The standard requires
+ * implementations to silently truncate values exceeding this maximum
+ * to the maximum. Unfortunately, OSX and the BSD don't comply with
+ * SUSv2, instead opting to return EINVAL for values exceeding a
+ * timeout of 1e8.
+ *
+ * Select returning an error crashes the runtime in a bad way. To
+ * play it safe we truncate any timeout to 31 days, as SUSv2 requires
+ * any implementations maximum timeout to be larger than this.
+ *
+ * Truncating the timeout is not an issue, because if nothing
+ * interesting happens when the timeout expires, we'll see that the
+ * thread still wants to be blocked longer and simply block on a new
+ * iteration of select(2).
+ */
+ const time_t max_seconds = 2678400; // 31 * 24 * 60 * 60
+
+ Time waketime = findMinWaketimeTimeoutQueue(iomgr->timeout_queue);
+ Time waittime = waketime - now;
+
+ /* Any expired timeouts should have been cleared, so we must be waiting
+ * for a timeout in the future. */
+ ASSERT(waittime > 0);
+
+ tv->tv_sec = TimeToSeconds(waittime);
+ if (tv->tv_sec < max_seconds) {
+ tv->tv_usec = TimeToUS(waittime) % 1000000;
+ } else {
+ tv->tv_sec = max_seconds;
+ tv->tv_usec = 0;
+ }
+ return tv;
+
+ } else {
+ return NULL;
+ }
+}
+#endif
+
+#endif // defined(IOMGR_ENABLED_POLL) || ... etc
=====================================
rts/posix/Timeout.h
=====================================
@@ -46,5 +46,15 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
Time now, struct timespec *tv);
#endif
+/* As above, but a timeout in microseconds. This is intended to be used with
+ * select() which expect struct timespec *, with special values of NULL for
+ * indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv);
+
+#endif
+
#include "EndPrivate.h"
=====================================
rts/rts.cabal
=====================================
@@ -568,6 +568,7 @@ library
wasm/JSFFI.c
wasm/JSFFIGlobals.c
posix/Select.c
+ posix/SelectBis.c
posix/Poll.c
posix/Timeout.c
cmm-sources: wasm/jsval.cmm
@@ -583,6 +584,7 @@ library
posix/MIO.c
posix/Poll.c
posix/Select.c
+ posix/SelectBis.c
posix/Signals.c
posix/Timeout.c
posix/TTY.c
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -7861,7 +7861,7 @@ module GHC.RTS.Flags.Experimental where
type HpcFlags :: *
data HpcFlags = HpcFlags {readTixFile :: GHC.Internal.Types.Bool, writeTixFile :: GHC.Internal.Types.Bool}
type IoManagerFlag :: *
- data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
+ data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagSelectBis | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -7864,7 +7864,7 @@ module GHC.RTS.Flags.Experimental where
type HpcFlags :: *
data HpcFlags = HpcFlags {readTixFile :: GHC.Internal.Types.Bool, writeTixFile :: GHC.Internal.Types.Bool}
type IoManagerFlag :: *
- data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
+ data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagSelectBis | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/471450f42ed49fabd3d80beedb3677…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/471450f42ed49fabd3d80beedb3677…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 14 Sep '26
by Andreas Klebinger (＠AndreasK) 14 Sep '26
14 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
7f0ac23c by Andreas Klebinger at 2026-09-14T20:03:20+00:00
.hi files: Various encoding improvements
Binders: Encode non-linear binders more efficiently.
There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.
Names: Use the low rather than high bit to encode the "compactness".
Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.
This allows use to LEB128 encode the combination of tag + value efficiently.
instance Binary Integer:
We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.
Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.
instance Binary iteral:
Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.
This saves a byte per literal for small numbers.
`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.
We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:
IfaceApps IfaceExpr [IfaceExpr]
Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.
Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.
`IfaceAlt`: Improve the encoding
We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.
`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.
- - - - -
14 changed files:
- + changelog.d/T27808-iface-encoding-improvements
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Utils/Binary.hs
- + testsuite/tests/utils/should_run/Binary_Literal.hs
- + testsuite/tests/utils/should_run/Binary_Literal.stdout
- testsuite/tests/utils/should_run/all.T
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
+issues: #27808
+mrs: !16683
+description: {
+ This was mostly done by moving from simple pointwise encoding to adding
+ special cases for common cases.
+}
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
+-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
+-- See Note [Iface applications] in GHC.Iface.Syntax
+mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
= -- See Note [Inlining and hs-boot files]
- IfaceApp (IfaceApp (IfaceExt noinline_id)
- (IfaceType (toIfaceType ty)))
- (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
+ IfaceApps (IfaceExt noinline_id)
+ [IfaceType (toIfaceType ty), IfaceExt name]
+ -- don't use mkIfaceApps, or infinite loop since it ends up calling
+ -- toIfaceVar indirectly again.
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -741,25 +741,38 @@ In more detail:
Tuples aren't included in the wired-in names map: see (ST1) below
* Serialisation is done by `putName`:
- - When we serialise a compact Name,
- we serialise it as a single 32-bit word:
- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
- where xxxx is the tag, and yyyy is the payload.
- The function `wiredInNamesOkay` checks that the wired-in names all have
- uniques that fit into the `yyy` field.
+ - When we serialise a compact Name, we serialise its Unique, split by
+ `unpkUniqueGrimily` into the tag character and the payload:
+
+ yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
+ \________ payload _______/\_ tag _/^ marker bit
+
+ Why are we storing the marker/tag in the low rather than high bits? Because
+ we LEB128 encode the whole word when writing to disk so we want to keep as
+ many of the high bits zero as possible to allow for shorter encodings. See
+ also wrinkle ST3.
+
+ Tags are 8 bits by construction, and there is a check that the actual unique
+ part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
+ known-key names.
- When we serialise a non-compact name:
- We look it up in the (stateful, growing) symbol table
- - If it not there we add it to the symbol table
- - We serialise the occurrenc to a single 32-bit word:
- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
- where `xxxxx` is an index into the symbol table.
+ - If it is not there we add it to the symbol table
+ - We serialise the occurrence as
-* Deserialision is done by `getName`. We read a 32-bit word
- - If the MSB is `10` it must be a compact name, so we use
+ 0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
+
+ In other words we simply shift the index by a bit.
+ The high bit is currently unused. But `putSymtabNameRef`
+ asserts that `ix` fits in 30 bits.
+
+* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
+ of the word it reads:
+ - If it is 1 it must be a compact name, so we reassemble the Unique and use
`lookupCompactName` to get from the Unique to the Name.
- - If the MSB is `00` it must be a non-compact Name,
- so we look it up in the symbol table.
+ - If it is 0 it must be a non-compact Name, so we look it up in the
+ symbol table.
Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
`isCompactName` that tests for `knownUniqueTupleName` and then the
TyConRepNames would be serialised as non-compact names, and everything would
work. Fewer tests, but Typeable-heavy code might have bigger interface files.
+
+(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
+ disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
+ This has consequences as it means we want to keep the high bits zero where possible
+ to allow for a shorter ULEB128 encoding.
+
+ This is why we put both the tag and the marker bit at the LSB end of the word. They
+ are always present. But by putting them at the low end we ensure LEB128 encoding
+ still works as expected, producing smaller encodings for compact names with small
+ uniques.
+
+ The downside is that we steal one bit from non-compact names for which the marker
+ bit and tag would have been zero either way. But in practice this matters far less
+ than ensuring built in (compact) names encode well.
-}
isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
where
(tag, ix) = unpkUniqueGrimily u
+-- | Write a reference to a symbol table index.
+-- See Note [Symbol table representation of names]
+putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
+{-# INLINE putSymtabNameRef #-}
+putSymtabNameRef bh ix
+ = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
+ (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
+ -- Bit 0 == False marks a symbol table reference
+ put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
+
+-- | Write a reference to a compact (known-key) 'Name'.
+-- See Note [Symbol table representation of names]
+putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
+{-# INLINE putCompactNameRef #-}
+putCompactNameRef bh uniq
+ = -- INVARIANTS:
+ -- * 8 bits tag (true by construction)
+ -- * the payload fits in 22 bits (checked for all known keys elsewhere)
+ -- Bit 0 == True marks a compact (known-key) name
+ put_ bh ( (fromIntegral payload `shiftL` 9)
+ .|. (fromIntegral (ord tag) `shiftL` 1)
+ .|. 1 :: Word32)
+ where
+ (tag, payload) = unpkUniqueGrimily uniq
+
-- See Note [Symbol table representation of names]
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isCompactName name
- , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
+ = putCompactNameRef bh (nameUnique name)
| otherwise
= do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putSymtabNameRef bh off
Nothing -> do
off <- freshIndex
let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
- put_ bh (fromIntegral off :: Word32)
+ putSymtabNameRef bh off
where
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral i
- 0x80000000 -> return $! lookupCompactName u
- where
- tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- u = mkUniqueGrimilyWithTag tag ix
-
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+ if i .&. 1 == 0
+ then -- Symbol table reference, written by putSymtabNameRef
+ return $! symtab ! fromIntegral (i `shiftR` 1)
+ else -- Compact name, written by putCompactNameRef
+ let tag = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
+ payload = fromIntegral (i `shiftR` 9) :: Word64
+ in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
= IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
= IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceApps fun args)
+ = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
rnIfaceExpr (IfaceCase scrut case_bndr alts)
= IfaceCase <$> rnIfaceExpr scrut
<*> pure case_bndr
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
+ IfaceExpr(..), mkIfaceApp,
+ IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- zipWithEqual )
+import GHC.Utils.Misc( dropList, filterByList, notNull,
+ unzipWith, zipWithEqual )
import GHC.Data.FastString
import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceLamBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
+ -- ^ Application to exactly one argument.
+ -- See Note [Iface applications]
+ | IfaceApps IfaceExpr [IfaceExpr]
+ -- ^ Application to two or more arguments.
+ -- See Note [Iface applications]
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+-- | Apply an expression to a (possibly empty) list of arguments, maintaining
+-- the invariants of 'IfaceApp' and 'IfaceApps'.
+-- See Note [Iface applications].
+mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
+mkIfaceApp fun args = go fun args
+ where
+ go (IfaceApp f a) as = go f (a : as)
+ go (IfaceApps f fs) as = go f (fs ++ as)
+
+ go f [] = f
+ go f [a] = IfaceApp f a
+ go f as = IfaceApps f as
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
{-
+Note [Iface applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A Core application chain (f a1 a2 ... an) could be represented by a chain of
+n nested IfaceApp nodes like Core does. However this is generally a worse
+representation for *serialization* which is the main purpose of the Iface type.
+
+So we keep the single argument constructor as it's fairly common, and add one
+to represent multiple arguments:
+
+ * IfaceApp f a -- exactly one argument
+ * IfaceApps f [a1,..] -- two or more arguments
+
+with two invariants:
+
+ (1) The argument list of an IfaceApps has at least two elements.
+ (A one-argument application is an IfaceApp, and a zero-argument
+ "application" is just the head itself.)
+
+ (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
+ IfaceApps: application chains are fully flattened.
+
+The smart constructor 'mkIfaceApp' establishes both invariants; producers
+should use it rather than building IfaceApps directly.
+
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
<> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
<> parens (ppr r)
-pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
+-- that --show-iface output does not depend on which one the producer emitted.
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
nest 2 (pprParendIfaceExpr arg) : args
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApps fun as) args = pprIfaceApp fun $
+ map (nest 2 . pprParendIfaceExpr) as ++ args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceApps f as) = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
{-# INLINE (.<<|.) #-}
+-- Encoding shortcuts:
+-- Since only IfaceDataAlt can have binders
+-- we can skip the binder list for DEFAULT and Literal alternatives.
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
- put_ bh b
+ case a of
+ IfaceDataAlt {} -> put_ bh b
+ _ -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
put_ bh c
get bh = do
a <- get bh
- b <- get bh
+ b <- case a of
+ IfaceDataAlt {} -> get bh
+ _ -> return []
c <- get bh
return (IfaceAlt a b c)
+{- Note [IfaceExpr encoding shortcuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use a full byte to encode the constructor tag for `IfaceExpr`.
+This leaves room to encode additional information. Concretely we
+use:
+
+0 .. 14: "Simple" constructor tags.
+15 .. 22: "IfaceApps", encoding the constructor *and* arity.
+ 23: "IfaceCase" for a case with a single default alternative.
+
+Note [Binary encoding of IfaceApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For IfaceApps we use the following scheme:
+
+ * arity 2..8: one byte encoding the arity as (15 + (n-2))
+ Which is followed by the head expression and then exactly `arity` arguments.
+
+ * arity > 8: tag 22, and we serialize the argument count as a ULEB128, followed by the
+ head expression and arguments.
+
+This saves us one byte per application with `2 <= arity <= 8`.
+-}
instance Binary IfaceExpr where
put_ bh (IfaceLcl aa) = do
putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
putByte bh 5
put_ bh ag
put_ bh ah
+ -- See Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
+ putByte bh 23
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
put_ bh (IfaceCase ai aj ak) = do
putByte bh 6
put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
putByte bh 14
put_ bh r
put_ bh torc
+ -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
+ -- and Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceApps fun args) = do
+ let !n = length args
+ massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
+ if n <= maxIfaceAppsTagArity
+ then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
+ else do putByte bh (fromIntegral ifaceAppsBigTag)
+ put_ bh n
+ put_ bh fun
+ mapM_ (put_ bh) args
get bh = do
h <- getByte bh
case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
14 -> do r <- get bh
torc <- get bh
return (IfaceLitRubbish torc r)
+ -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
+ -- tag 22 is followed by an explicit (LEB128) argument count.
+ -- See Note [Binary encoding of IfaceApps]
+ 15 -> getApps 2
+ 16 -> getApps 3
+ 17 -> getApps 4
+ 18 -> getApps 5
+ 19 -> getApps 6
+ 20 -> getApps 7
+ 21 -> getApps 8
+ 22 -> do n <- get bh
+ getApps n
+ -- case scrut of bndr { DEFAULT -> rhs}
+ 23 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
_ -> panic ("get IfaceExpr " ++ show h)
+ where
+ getApps :: Int -> IO IfaceExpr
+ getApps n = do fun <- get bh
+ args <- replicateM n (get bh)
+ return (IfaceApps fun args)
+-- | Tag used for an 'IfaceApps' with exactly two arguments and start
+-- of the ifaceApps tag range.
+ifaceAppsTag0 :: Int
+ifaceAppsTag0 = 15
+
+-- | Highest arity encoded directly in tag byte.
+maxIfaceAppsTagArity :: Int
+maxIfaceAppsTagArity = 8
+
+-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
+ifaceAppsBigTag :: Int
+ifaceAppsBigTag = 22
instance Binary IfaceTickish where
put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
+ IfaceApps e es -> rnf e `seq` rnf es
IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
where
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
+-- | IfaceBndr shortcuts:
+--
+-- In the vast majority of cases binder multiplicity is `Many` so storing it is
+-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
+-- (Name,Ty) in the common case where multiplicity == Many.
instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr (mult, name, ty))
+ -- The implicit Many shortcut.
+ | mult == many_ty = do
+ putByte bh 2
+ put_ bh name
+ put_ bh ty
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
- _ -> do ab <- get bh
+ 1 -> do ab <- get bh
return (IfaceTvBndr ab)
+ _ -> do name <- get bh
+ ty <- get bh
+ return (IfaceIdBndr (many_ty, name, ty))
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot =
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceApps f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+tcIfaceExpr (IfaceApps fun args)
+ = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
+
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -167,7 +167,7 @@ data LitNumType
| LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
| LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
- deriving (Data,Enum,Eq,Ord)
+ deriving (Data,Enum,Eq,Ord,Bounded)
-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
-}
+{-
+Note [Binary Literal encoding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than write `LitNumType` into it's own tag byte we encode it in the
+surplus space of the `Literal` tag space.
+
+This means for `Literal` tag 0 .. 5 are the non-num literals.
+Literals 6 .. (maxBound LitNumType) encode the LitNumType.
+
+We could use the `LitNumType` information to slightly improve the encoding of
+the actual values too. But we just write/read them at Integer for simplicity for
+now.
+-}
+
+-- | The 'Binary' tag byte of @'LitNumber' nt _@.
+--
+-- These continue the tags of the non-numeric 'Literal' constructors. The
+-- mapping is total and part of the interface file format.
+-- See Note [Binary Literal encoding].
+litNumTypeTag :: LitNumType -> Word8
+litNumTypeTag nt =
+ -- 6 .. 16
+ 6 + (fromIntegral $ fromEnum nt)
+
+-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
+-- of a numeric literal. See Note [Binary Literal encoding].
+litNumTypeOfTag :: Word8 -> Maybe LitNumType
+litNumTypeOfTag tag
+ | tag >= 6 && tag <= 16
+ = Just (toEnum $ (fromIntegral tag) - 6)
+ | otherwise = Nothing
+
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
= do putByte bh 5
put_ bh aj
put_ bh fod
+ -- The LitNumType is part of the tag byte.
+ -- See Note [Binary Literal encoding]
put_ bh (LitNumber nt i)
- = do putByte bh 6
- put_ bh nt
+ = do putByte bh (litNumTypeTag nt)
put_ bh i
put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
-- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
aj <- get bh
fod <- get bh
return (LitLabel aj fod)
- 6 -> do
- nt <- get bh
- i <- get bh
- return (LitNumber nt i)
- _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+ _ | Just nt <- litNumTypeOfTag h
+ -> do i <- get bh
+ return (LitNumber nt i)
+ | otherwise
+ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance NFData Literal where
rnf (LitChar c) = rnf c
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
case unpkUniqueGrimily u of
- (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+ (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -148,7 +148,7 @@ import GHCi.FFI
import GHCi.Message
import Control.DeepSeq
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Control.Monad ( when, unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time hiding ( Nominal )
-import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import Type.Reflection ( Typeable, SomeTypeRep(..) )
@@ -188,6 +187,7 @@ import GHC.ForeignPtr ( unsafeWithForeignPtr )
import GHC.Exts
import GHC.IO
import GHC.Word
+import GHC.Num (Integer(IS))
import Unsafe.Coerce (unsafeCoerce)
import GHC.Serialized
@@ -805,6 +805,7 @@ getULEB128 bh =
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
@@ -1123,86 +1124,91 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-We used to encode values in the Int32 range as such,
-falling back to a string of all things. In either case
-we stored a tag byte to discriminate between the two cases.
+This is a tradeoff:
+It allows shorter encodings for the common case of small values. And we don't need
+to prefix the string with a byte carrying any information about size or sign.
-This made some sense as it's highly portable but also not very
-efficient.
+However it means large Integer values will pay some overhead. Their encoding can
+go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
+into a `Integer` accumulator rather than a simple Word64#.
-However GHC stores a surprisingly large number of large Integer
-values. In the examples looked at between 25% and 50% of Integers
-serialized were outside of the Int32 range.
+In practice interface files have enough small values to make this tradeoff worthwhile.
+We could also restore this benefit by using one or two *bits* rather than a full
+byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
+gone as for for the sake of avoiding complexity.
-Consider a value like `2724268014499746065`, some sort of hash
-actually generated by GHC.
-In the old scheme this was encoded as a list of 19 chars. This
-gave a size of 77 Bytes, one for the length of the list and 76
-since we encode chars as Word32 as well.
-We can easily do better. The new plan is:
-
-* Start with a tag byte
- * 0 => Int64 (LEB128 encoded)
- * 1 => Negative large integer
- * 2 => Positive large integer
-* Followed by the value:
- * Int64 is encoded as usual
- * Large integers are encoded as a list of bytes (Word8).
- We use Data.Bits which defines a bit order independent of the representation.
- Values are stored LSB first.
-
-This means our example value `2724268014499746065` is now only 10 bytes large.
-* One byte tag
-* One byte for the length of the [Word8] list.
-* 8 bytes for the actual date.
-
-The new scheme also does not depend in any way on
-architecture specific details.
-
-We still use this scheme even with LEB128 available,
-as it has less overhead for truly large numbers. (> maxBound :: Int64)
-
-The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}
instance Binary Integer where
- put_ bh i
- | i >= lo64 && i <= hi64 = do
- putWord8 bh 0
- put_ bh (fromIntegral i :: Int64)
- | otherwise = do
- if i < 0
- then putWord8 bh 1
- else putWord8 bh 2
- put_ bh (unroll $ abs i)
+ -- See Note [Integer serialisation]
+ put_ bh (IS i)
+ = putSLEB128 bh (I# i)
+ put_ bh large_i
+ = putSLEB128 bh large_i
where
- lo64 = fromIntegral (minBound :: Int64)
- hi64 = fromIntegral (maxBound :: Int64)
- get bh = do
- int_kind <- getWord8 bh
- case int_kind of
- 0 -> fromIntegral <$!> (get bh :: IO Int64)
- -- Large integer
- 1 -> negate <$!> getInt
- 2 -> getInt
- _ -> panic "Binary Integer - Invalid byte"
- where
- getInt :: IO Integer
- getInt = roll <$!> (get bh :: IO [Word8])
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
+ get bh = getSLEB128Integer bh
-roll :: [Word8] -> Integer
-roll = foldl' unstep 0 . reverse
+-- | Read an SLEB128 encoded 'Integer'.
+--
+-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
+-- 'Integer' lacks. See Note [Integer serialisation].
+getSLEB128Integer :: ReadBinHandle -> IO Integer
+getSLEB128Integer bh = go_word 0 0
where
- unstep a b = a `shiftL` 8 .|. fromIntegral b
+ -- Accumulate in a Word64 for as long as possible
+ go_word :: Int -> Word64 -> IO Integer
+ go_word !shift !acc = do
+ byte <- getByte bh
+ let !byteVal = clearBit byte 7
+ let more = testBit byte 7
+ let !shift' = shift + 7 -- bits read *after* this step
+ -- Check if the payload still fits in the accumulator,
+ -- if not swap to a Integer accumulator.
+ if shift' <= 64
+ then do
+ let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
+ if more
+ then go_word shift' acc'
+ else return $! signExtendWord shift' acc' (testBit byte 6)
+ else do
+ -- They don't, so from here on out we use Integer arithmetic.
+ let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ go_big :: Int -> Integer -> IO Integer
+ go_big !shift !acc = do
+ byte <- getByte bh
+ let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift + 7
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ -- Sign extend a value of which we read `shift` bits into a Word64.
+ -- `shift` is always <= 64 here, so the result always fits into an Int64.
+ signExtendWord :: Int -> Word64 -> Bool -> Integer
+ signExtendWord !shift !acc signed
+ | not signed
+ = toInteger acc
+ | shift < 64
+ -- set high bits not encoded in the payload
+ = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
+ | otherwise
+ = toInteger (fromIntegral acc :: Int64)
+
+ -- Sign extend into an Integer.
+ signExtendInteger :: Int -> Integer -> Bool -> Integer
+ signExtendInteger !shift !acc signed
+ | signed = acc - (1 `shiftL` shift)
+ | otherwise = acc
{-
=====================================
testsuite/tests/utils/should_run/Binary_Literal.hs
=====================================
@@ -0,0 +1,280 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+-- LLM generated test. So if it's weird it's for no good reason.
+--
+-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
+--
+-- We check that
+-- * arbitrary literals round trip through 'put_' and 'get',
+-- * a whole batch of literals written into one buffer reads back in order,
+-- that is the reader consumes exactly the bytes the writer produced,
+-- * and, since numeric literals carry an 'Integer', that the SLEB128 based
+-- 'Binary Integer' instance agrees with a reference implementation.
+module Main (main) where
+
+import GHC.Data.FastString
+import GHC.Platform ( genericPlatform )
+import GHC.Types.Basic ( FunctionOrData(..) )
+import GHC.Types.Literal
+import GHC.Types.Literal.Floating
+import GHC.Utils.Binary
+
+import Control.Monad ( replicateM )
+import Data.Bits
+import qualified Data.ByteString as BS
+import Data.Ratio ( (%) )
+import Data.Word
+import GHC.Float ( castFloatToWord32, castWord32ToFloat
+ , castDoubleToWord64, castWord64ToDouble )
+import Numeric ( showHex )
+import System.IO.Unsafe ( unsafePerformIO )
+
+import MiniQuickCheck
+
+--------------------------------------------------------------------------------
+-- Encoding and decoding
+
+-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
+-- through a table in the handle's user data. Interface files fill this in with
+-- a deduplication table. We only need something that round trips, so we write
+-- the bytes of the string inline.
+withFastStringWriter :: WriteBinHandle -> WriteBinHandle
+withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
+
+withFastStringReader :: ReadBinHandle -> ReadBinHandle
+withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
+
+-- | Serialise the values and also return the position after the last of them.
+encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
+encodeAll xs = unsafePerformIO $ do
+ bh <- withFastStringWriter <$> openBinMem 1024
+ mapM_ (put_ bh) xs
+ end <- tellBinWriter bh
+ bs <- withBinBuffer bh (return . BS.copy)
+ return (bs, end)
+
+encode :: Binary a => a -> BS.ByteString
+encode x = fst (encodeAll [x])
+
+-- | Read back @n@ values and check that doing so consumed exactly the bytes
+-- the writer produced, no more and no less.
+decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
+decodeAll n (bs, end) = unsafePerformIO $ do
+ bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
+ xs <- replicateM n (get bh)
+ end' <- tellBinReader bh
+ if end' == end
+ then return xs
+ else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
+
+roundTrip :: Binary a => [a] -> [a]
+roundTrip xs = decodeAll (length xs) (encodeAll xs)
+
+roundTrip1 :: Binary a => a -> a
+roundTrip1 x = case roundTrip [x] of
+ [x'] -> x'
+ _ -> error "roundTrip1"
+
+--------------------------------------------------------------------------------
+-- Literals with structural equality and a Show instance
+
+-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
+-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
+-- identifies the different representations of the same value. For a
+-- serialisation test we want the stricter notion.
+newtype Lit = Lit Literal
+
+instance Show Lit where
+ show (Lit l) = showLit l
+
+instance Eq Lit where
+ Lit a == Lit b = eqLit a b
+
+eqLit :: Literal -> Literal -> Bool
+eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
+ = fs1 == fs2 && fod1 == fod2
+eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
+ -- 'Eq LitFloating' compares NaNs bitwise but identifies different
+ -- representations of the same value; the derived 'Show' distinguishes the
+ -- representations but not NaN payloads. Together they compare structurally.
+ = ty1 == ty2 && v1 == v2 && show v1 == show v2
+eqLit a b = a == b
+
+showLit :: Literal -> String
+showLit lit = case lit of
+ LitChar c -> "LitChar " ++ show c
+ LitNumber nt i -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
+ LitString bs -> "LitString " ++ show bs
+ LitNullAddr -> "LitNullAddr"
+ LitRubbish {} -> "LitRubbish"
+ LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
+ LitLabel fs fod -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
+ where
+ -- The bit pattern is needed to tell apart NaNs.
+ bits LitFloat v = "0x" ++ showHex (castFloatToWord32 (litFloatingToHostFloat v)) ""
+ bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
+
+ showFod IsFunction = "IsFunction"
+ showFod IsData = "IsData"
+
+showLitNumType :: LitNumType -> String
+showLitNumType nt = case nt of
+ LitNumBigNat -> "LitNumBigNat"
+ LitNumInt -> "LitNumInt"
+ LitNumInt8 -> "LitNumInt8"
+ LitNumInt16 -> "LitNumInt16"
+ LitNumInt32 -> "LitNumInt32"
+ LitNumInt64 -> "LitNumInt64"
+ LitNumWord -> "LitNumWord"
+ LitNumWord8 -> "LitNumWord8"
+ LitNumWord16 -> "LitNumWord16"
+ LitNumWord32 -> "LitNumWord32"
+ LitNumWord64 -> "LitNumWord64"
+
+--------------------------------------------------------------------------------
+-- Generators
+
+-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
+-- more random ones.
+choose :: Int -> Gen Int
+choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
+
+oneOf :: [Gen a] -> Gen a
+oneOf gens = do
+ i <- choose (length gens)
+ gens !! i
+
+listOf :: Int -> Gen a -> Gen [a]
+listOf maxLen gen = do
+ n <- choose (maxLen + 1)
+ replicateM n gen
+
+-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
+-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
+-- values and values around powers of two.
+genInteger :: Gen Integer
+genInteger = oneOf
+ [ arbitrary
+ , fromIntegral . subtract 300 <$> choose 601
+ , do k <- choose 200
+ d <- subtract 2 <$> choose 5
+ neg <- arbitrary
+ let v = 2 ^ k + toInteger d
+ return (if neg then negate v else v)
+ ]
+
+genLitNumType :: Gen LitNumType
+genLitNumType = oneOf (map pure [LitNumBigNat ..])
+
+-- | Numeric literals are always in range for their type, see
+-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
+-- free to rely on that, so we generate only such literals.
+genLitNumber :: Gen Literal
+genLitNumber = do
+ nt <- genLitNumType
+ i <- genInteger
+ -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
+ -- refuses negative 'BigNat's.
+ let i' | LitNumBigNat <- nt = abs i
+ | otherwise = i
+ return (mkLitNumberWrap genericPlatform nt i')
+
+-- | Random bit patterns, so that we also get infinities, negative zero,
+-- subnormals and NaNs with various payloads.
+genFloat :: Gen Float
+genFloat = castWord32ToFloat <$> arbitrary
+
+genDouble :: Gen Double
+genDouble = castWord64ToDouble <$> arbitrary
+
+genRational :: Gen Rational
+genRational = do
+ n <- genInteger
+ NonZero d <- arbitrary @(NonZero Integer)
+ return (n % d)
+
+genLitFloating :: Gen LitFloating
+genLitFloating = oneOf
+ [ floatToLitFloating <$> genFloat
+ , doubleToLitFloating <$> genDouble
+ , rationalToLitFloating <$> genRational
+ ]
+
+genLitFloatingType :: Gen LitFloatingType
+genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
+
+genByteString :: Gen BS.ByteString
+genByteString = BS.pack <$> listOf 64 arbitrary
+
+genFunctionOrData :: Gen FunctionOrData
+genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
+
+-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
+-- Note [Rubbish literals] in GHC.Types.Literal.
+genLiteral :: Gen Literal
+genLiteral = oneOf
+ [ LitChar <$> arbitrary
+ , genLitNumber
+ , LitString <$> genByteString
+ , pure LitNullAddr
+ , LitFloating <$> genLitFloatingType <*> genLitFloating
+ , LitLabel <$> (mkFastStringByteString <$> genByteString) <*> genFunctionOrData
+ ]
+
+instance Arbitrary Lit where
+ arbitrary = Lit <$> genLiteral
+
+newtype Lits = Lits [Lit]
+ deriving (Eq, Show)
+
+instance Arbitrary Lits where
+ arbitrary = Lits <$> listOf 32 arbitrary
+
+newtype I = I Integer
+ deriving (Eq, Show)
+
+instance Arbitrary I where
+ arbitrary = I <$> genInteger
+
+--------------------------------------------------------------------------------
+-- Properties
+
+-- | Reference implementation of the SLEB128 encoding.
+slebRef :: Integer -> [Word8]
+slebRef = go
+ where
+ go val =
+ let byte = fromIntegral (val .&. 0x7f) :: Word8
+ val' = val `shiftR` 7
+ signBit = testBit byte 6
+ done = (val' == 0 && not signBit) || (val' == -1 && signBit)
+ in if done
+ then [byte]
+ else setBit byte 7 : go val'
+
+prop_literalRoundTrip :: Lit -> PropertyCheck
+prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
+
+prop_literalBatchRoundTrip :: Lits -> PropertyCheck
+prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
+
+prop_integerRoundTrip :: I -> PropertyCheck
+prop_integerRoundTrip (I i) = roundTrip1 i === i
+
+prop_integerEncoding :: I -> PropertyCheck
+prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
+
+tests :: Test
+tests = Group "Binary"
+ [ Group "Literal"
+ [ Property "round trip" prop_literalRoundTrip
+ , Property "batch round trip" prop_literalBatchRoundTrip
+ ]
+ , Group "Integer"
+ [ Property "round trip" prop_integerRoundTrip
+ , Property "SLEB128 encoding" prop_integerEncoding
+ ]
+ ]
+
+main :: IO ()
+main = runTestsMain (Iterations 1000) tests
=====================================
testsuite/tests/utils/should_run/Binary_Literal.stdout
=====================================
@@ -0,0 +1,11 @@
+Group Binary
+ Group Literal
+ Running round trip
+ Passed 1000 iterations
+ Running batch round trip
+ Passed 1000 iterations
+ Group Integer
+ Running round trip
+ Passed 1000 iterations
+ Running SLEB128 encoding
+ Passed 1000 iterations
=====================================
testsuite/tests/utils/should_run/all.T
=====================================
@@ -1 +1,6 @@
test('T15953', [ignore_stdout, js_skip], makefile_test, [])
+
+# Property tests for the 'Binary Literal' instance, which also exercises
+# GHCs 'Binary Integer' instance.
+test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
+ ['Binary_Literal', '-package ghc'])
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -60,6 +60,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Data.Text as T
import Haddock.Options (Visibility (..))
+import qualified Data.Bits as Bits
data InterfaceFile = InterfaceFile
{ ifLinkEnv :: LinkEnv
@@ -143,7 +144,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
-binaryInterfaceVersion = 47
+binaryInterfaceVersion = 48
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -274,7 +275,7 @@ putName
do
(symtab_map, symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putNameIndex (fromIntegral off :: Word32)
Nothing -> do
off <- freshIndex
let mod' = nameModule name
@@ -283,8 +284,10 @@ putName
let !symtab_map' = extendNameEnv symtab_map name off
let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
- put_ bh (fromIntegral off :: Word32)
+ putNameIndex (fromIntegral off)
where
+ putNameIndex :: Word32 -> IO ()
+ putNameIndex off = put_ bh (off `Bits.shiftL` 1)
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f0ac23c89b040e2d178619a74d327c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f0ac23c89b040e2d178619a74d327c…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 14 Sep '26
by Andreas Klebinger (＠AndreasK) 14 Sep '26
14 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
eb587819 by Andreas Klebinger at 2026-09-14T19:47:11+00:00
.hi files: Various encoding improvements
Binders: Encode non-linear binders more efficiently.
There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.
Names: Use the low rather than high bit to encode the "compactness".
Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.
This allows use to LEB128 encode the combination of tag + value efficiently.
instance Binary Integer:
We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.
Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.
instance Binary iteral:
Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.
This saves a byte per literal for small numbers.
`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.
We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:
IfaceApps IfaceExpr [IfaceExpr]
Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.
Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.
`IfaceAlt`: Improve the encoding
We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.
`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.
- - - - -
13 changed files:
- + changelog.d/T27808-iface-encoding-improvements
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Utils/Binary.hs
- + testsuite/tests/utils/should_run/Binary_Literal.hs
- + testsuite/tests/utils/should_run/Binary_Literal.stdout
- testsuite/tests/utils/should_run/all.T
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
+issues: #27808
+mrs: !16683
+description: {
+ This was mostly done by moving from simple pointwise encoding to adding
+ special cases for common cases.
+}
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
+-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
+-- See Note [Iface applications] in GHC.Iface.Syntax
+mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
= -- See Note [Inlining and hs-boot files]
- IfaceApp (IfaceApp (IfaceExt noinline_id)
- (IfaceType (toIfaceType ty)))
- (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
+ IfaceApps (IfaceExt noinline_id)
+ [IfaceType (toIfaceType ty), IfaceExt name]
+ -- don't use mkIfaceApps, or infinite loop since it ends up calling
+ -- toIfaceVar indirectly again.
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -741,25 +741,38 @@ In more detail:
Tuples aren't included in the wired-in names map: see (ST1) below
* Serialisation is done by `putName`:
- - When we serialise a compact Name,
- we serialise it as a single 32-bit word:
- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
- where xxxx is the tag, and yyyy is the payload.
- The function `wiredInNamesOkay` checks that the wired-in names all have
- uniques that fit into the `yyy` field.
+ - When we serialise a compact Name, we serialise its Unique, split by
+ `unpkUniqueGrimily` into the tag character and the payload:
+
+ yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
+ \________ payload _______/\_ tag _/^ marker bit
+
+ Why are we storing the marker/tag in the low rather than high bits? Because
+ we LEB128 encode the whole word when writing to disk so we want to keep as
+ many of the high bits zero as possible to allow for shorter encodings. See
+ also wrinkle ST3.
+
+ Tags are 8 bits by construction, and there is a check that the actual unique
+ part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
+ known-key names.
- When we serialise a non-compact name:
- We look it up in the (stateful, growing) symbol table
- - If it not there we add it to the symbol table
- - We serialise the occurrenc to a single 32-bit word:
- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
- where `xxxxx` is an index into the symbol table.
+ - If it is not there we add it to the symbol table
+ - We serialise the occurrence as
-* Deserialision is done by `getName`. We read a 32-bit word
- - If the MSB is `10` it must be a compact name, so we use
+ 0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
+
+ In other words we simply shift the index by a bit.
+ The high bit is currently unused. But `putSymtabNameRef`
+ asserts that `ix` fits in 30 bits.
+
+* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
+ of the word it reads:
+ - If it is 1 it must be a compact name, so we reassemble the Unique and use
`lookupCompactName` to get from the Unique to the Name.
- - If the MSB is `00` it must be a non-compact Name,
- so we look it up in the symbol table.
+ - If it is 0 it must be a non-compact Name, so we look it up in the
+ symbol table.
Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
`isCompactName` that tests for `knownUniqueTupleName` and then the
TyConRepNames would be serialised as non-compact names, and everything would
work. Fewer tests, but Typeable-heavy code might have bigger interface files.
+
+(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
+ disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
+ This has consequences as it means we want to keep the high bits zero where possible
+ to allow for a shorter ULEB128 encoding.
+
+ This is why we put both the tag and the marker bit at the LSB end of the word. They
+ are always present. But by putting them at the low end we ensure LEB128 encoding
+ still works as expected, producing smaller encodings for compact names with small
+ uniques.
+
+ The downside is that we steal one bit from non-compact names for which the marker
+ bit and tag would have been zero either way. But in practice this matters far less
+ than ensuring built in (compact) names encode well.
-}
isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
where
(tag, ix) = unpkUniqueGrimily u
+-- | Write a reference to a symbol table index.
+-- See Note [Symbol table representation of names]
+putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
+{-# INLINE putSymtabNameRef #-}
+putSymtabNameRef bh ix
+ = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
+ (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
+ -- Bit 0 == False marks a symbol table reference
+ put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
+
+-- | Write a reference to a compact (known-key) 'Name'.
+-- See Note [Symbol table representation of names]
+putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
+{-# INLINE putCompactNameRef #-}
+putCompactNameRef bh uniq
+ = -- INVARIANTS:
+ -- * 8 bits tag (true by construction)
+ -- * the payload fits in 22 bits (checked for all known keys elsewhere)
+ -- Bit 0 == True marks a compact (known-key) name
+ put_ bh ( (fromIntegral payload `shiftL` 9)
+ .|. (fromIntegral (ord tag) `shiftL` 1)
+ .|. 1 :: Word32)
+ where
+ (tag, payload) = unpkUniqueGrimily uniq
+
-- See Note [Symbol table representation of names]
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isCompactName name
- , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
+ = putCompactNameRef bh (nameUnique name)
| otherwise
= do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putSymtabNameRef bh off
Nothing -> do
off <- freshIndex
let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
- put_ bh (fromIntegral off :: Word32)
+ putSymtabNameRef bh off
where
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral i
- 0x80000000 -> return $! lookupCompactName u
- where
- tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- u = mkUniqueGrimilyWithTag tag ix
-
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+ if i .&. 1 == 0
+ then -- Symbol table reference, written by putSymtabNameRef
+ return $! symtab ! fromIntegral (i `shiftR` 1)
+ else -- Compact name, written by putCompactNameRef
+ let tag = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
+ payload = fromIntegral (i `shiftR` 9) :: Word64
+ in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
= IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
= IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceApps fun args)
+ = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
rnIfaceExpr (IfaceCase scrut case_bndr alts)
= IfaceCase <$> rnIfaceExpr scrut
<*> pure case_bndr
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
+ IfaceExpr(..), mkIfaceApp,
+ IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- zipWithEqual )
+import GHC.Utils.Misc( dropList, filterByList, notNull,
+ unzipWith, zipWithEqual )
import GHC.Data.FastString
import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceLamBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
+ -- ^ Application to exactly one argument.
+ -- See Note [Iface applications]
+ | IfaceApps IfaceExpr [IfaceExpr]
+ -- ^ Application to two or more arguments.
+ -- See Note [Iface applications]
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+-- | Apply an expression to a (possibly empty) list of arguments, maintaining
+-- the invariants of 'IfaceApp' and 'IfaceApps'.
+-- See Note [Iface applications].
+mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
+mkIfaceApp fun args = go fun args
+ where
+ go (IfaceApp f a) as = go f (a : as)
+ go (IfaceApps f fs) as = go f (fs ++ as)
+
+ go f [] = f
+ go f [a] = IfaceApp f a
+ go f as = IfaceApps f as
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
{-
+Note [Iface applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A Core application chain (f a1 a2 ... an) could be represented by a chain of
+n nested IfaceApp nodes like Core does. However this is generally a worse
+representation for *serialization* which is the main purpose of the Iface type.
+
+So we keep the single argument constructor as it's fairly common, and add one
+to represent multiple arguments:
+
+ * IfaceApp f a -- exactly one argument
+ * IfaceApps f [a1,..] -- two or more arguments
+
+with two invariants:
+
+ (1) The argument list of an IfaceApps has at least two elements.
+ (A one-argument application is an IfaceApp, and a zero-argument
+ "application" is just the head itself.)
+
+ (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
+ IfaceApps: application chains are fully flattened.
+
+The smart constructor 'mkIfaceApp' establishes both invariants; producers
+should use it rather than building IfaceApps directly.
+
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
<> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
<> parens (ppr r)
-pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
+-- that --show-iface output does not depend on which one the producer emitted.
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
nest 2 (pprParendIfaceExpr arg) : args
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApps fun as) args = pprIfaceApp fun $
+ map (nest 2 . pprParendIfaceExpr) as ++ args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceApps f as) = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
{-# INLINE (.<<|.) #-}
+-- Encoding shortcuts:
+-- Since only IfaceDataAlt can have binders
+-- we can skip the binder list for DEFAULT and Literal alternatives.
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
- put_ bh b
+ case a of
+ IfaceDataAlt {} -> put_ bh b
+ _ -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
put_ bh c
get bh = do
a <- get bh
- b <- get bh
+ b <- case a of
+ IfaceDataAlt {} -> get bh
+ _ -> return []
c <- get bh
return (IfaceAlt a b c)
+{- Note [IfaceExpr encoding shortcuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use a full byte to encode the constructor tag for `IfaceExpr`.
+This leaves room to encode additional information. Concretely we
+use:
+
+0 .. 14: "Simple" constructor tags.
+15 .. 22: "IfaceApps", encoding the constructor *and* arity.
+ 23: "IfaceCase" for a case with a single default alternative.
+
+Note [Binary encoding of IfaceApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For IfaceApps we use the following scheme:
+
+ * arity 2..8: one byte encoding the arity as (15 + (n-2))
+ Which is followed by the head expression and then exactly `arity` arguments.
+
+ * arity > 8: tag 22, and we serialize the argument count as a ULEB128, followed by the
+ head expression and arguments.
+
+This saves us one byte per application with `2 <= arity <= 8`.
+-}
instance Binary IfaceExpr where
put_ bh (IfaceLcl aa) = do
putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
putByte bh 5
put_ bh ag
put_ bh ah
+ -- See Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
+ putByte bh 23
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
put_ bh (IfaceCase ai aj ak) = do
putByte bh 6
put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
putByte bh 14
put_ bh r
put_ bh torc
+ -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
+ -- and Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceApps fun args) = do
+ let !n = length args
+ massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
+ if n <= maxIfaceAppsTagArity
+ then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
+ else do putByte bh (fromIntegral ifaceAppsBigTag)
+ put_ bh n
+ put_ bh fun
+ mapM_ (put_ bh) args
get bh = do
h <- getByte bh
case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
14 -> do r <- get bh
torc <- get bh
return (IfaceLitRubbish torc r)
+ -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
+ -- tag 22 is followed by an explicit (LEB128) argument count.
+ -- See Note [Binary encoding of IfaceApps]
+ 15 -> getApps 2
+ 16 -> getApps 3
+ 17 -> getApps 4
+ 18 -> getApps 5
+ 19 -> getApps 6
+ 20 -> getApps 7
+ 21 -> getApps 8
+ 22 -> do n <- get bh
+ getApps n
+ -- case scrut of bndr { DEFAULT -> rhs}
+ 23 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
_ -> panic ("get IfaceExpr " ++ show h)
+ where
+ getApps :: Int -> IO IfaceExpr
+ getApps n = do fun <- get bh
+ args <- replicateM n (get bh)
+ return (IfaceApps fun args)
+-- | Tag used for an 'IfaceApps' with exactly two arguments and start
+-- of the ifaceApps tag range.
+ifaceAppsTag0 :: Int
+ifaceAppsTag0 = 15
+
+-- | Highest arity encoded directly in tag byte.
+maxIfaceAppsTagArity :: Int
+maxIfaceAppsTagArity = 8
+
+-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
+ifaceAppsBigTag :: Int
+ifaceAppsBigTag = 22
instance Binary IfaceTickish where
put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
+ IfaceApps e es -> rnf e `seq` rnf es
IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
where
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
+-- | IfaceBndr shortcuts:
+--
+-- In the vast majority of cases binder multiplicity is `Many` so storing it is
+-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
+-- (Name,Ty) in the common case where multiplicity == Many.
instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr (mult, name, ty))
+ -- The implicit Many shortcut.
+ | mult == many_ty = do
+ putByte bh 2
+ put_ bh name
+ put_ bh ty
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
- _ -> do ab <- get bh
+ 1 -> do ab <- get bh
return (IfaceTvBndr ab)
+ _ -> do name <- get bh
+ ty <- get bh
+ return (IfaceIdBndr (many_ty, name, ty))
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot =
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceApps f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+tcIfaceExpr (IfaceApps fun args)
+ = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
+
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -167,7 +167,7 @@ data LitNumType
| LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
| LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
- deriving (Data,Enum,Eq,Ord)
+ deriving (Data,Enum,Eq,Ord,Bounded)
-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
-}
+{-
+Note [Binary Literal encoding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than write `LitNumType` into it's own tag byte we encode it in the
+surplus space of the `Literal` tag space.
+
+This means for `Literal` tag 0 .. 5 are the non-num literals.
+Literals 6 .. (maxBound LitNumType) encode the LitNumType.
+
+We could use the `LitNumType` information to slightly improve the encoding of
+the actual values too. But we just write/read them at Integer for simplicity for
+now.
+-}
+
+-- | The 'Binary' tag byte of @'LitNumber' nt _@.
+--
+-- These continue the tags of the non-numeric 'Literal' constructors. The
+-- mapping is total and part of the interface file format.
+-- See Note [Binary Literal encoding].
+litNumTypeTag :: LitNumType -> Word8
+litNumTypeTag nt =
+ -- 6 .. 16
+ 6 + (fromIntegral $ fromEnum nt)
+
+-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
+-- of a numeric literal. See Note [Binary Literal encoding].
+litNumTypeOfTag :: Word8 -> Maybe LitNumType
+litNumTypeOfTag tag
+ | tag >= 6 && tag <= 16
+ = Just (toEnum $ (fromIntegral tag) - 6)
+ | otherwise = Nothing
+
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
= do putByte bh 5
put_ bh aj
put_ bh fod
+ -- The LitNumType is part of the tag byte.
+ -- See Note [Binary Literal encoding]
put_ bh (LitNumber nt i)
- = do putByte bh 6
- put_ bh nt
+ = do putByte bh (litNumTypeTag nt)
put_ bh i
put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
-- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
aj <- get bh
fod <- get bh
return (LitLabel aj fod)
- 6 -> do
- nt <- get bh
- i <- get bh
- return (LitNumber nt i)
- _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+ _ | Just nt <- litNumTypeOfTag h
+ -> do i <- get bh
+ return (LitNumber nt i)
+ | otherwise
+ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance NFData Literal where
rnf (LitChar c) = rnf c
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
case unpkUniqueGrimily u of
- (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+ (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -148,7 +148,7 @@ import GHCi.FFI
import GHCi.Message
import Control.DeepSeq
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Control.Monad ( when, unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time hiding ( Nominal )
-import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import Type.Reflection ( Typeable, SomeTypeRep(..) )
@@ -188,6 +187,7 @@ import GHC.ForeignPtr ( unsafeWithForeignPtr )
import GHC.Exts
import GHC.IO
import GHC.Word
+import GHC.Num (Integer(IS))
import Unsafe.Coerce (unsafeCoerce)
import GHC.Serialized
@@ -805,6 +805,7 @@ getULEB128 bh =
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
@@ -1123,86 +1124,91 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-We used to encode values in the Int32 range as such,
-falling back to a string of all things. In either case
-we stored a tag byte to discriminate between the two cases.
+This is a tradeoff:
+It allows shorter encodings for the common case of small values. And we don't need
+to prefix the string with a byte carrying any information about size or sign.
-This made some sense as it's highly portable but also not very
-efficient.
+However it means large Integer values will pay some overhead. Their encoding can
+go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
+into a `Integer` accumulator rather than a simple Word64#.
-However GHC stores a surprisingly large number of large Integer
-values. In the examples looked at between 25% and 50% of Integers
-serialized were outside of the Int32 range.
+In practice interface files have enough small values to make this tradeoff worthwhile.
+We could also restore this benefit by using one or two *bits* rather than a full
+byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
+gone as for for the sake of avoiding complexity.
-Consider a value like `2724268014499746065`, some sort of hash
-actually generated by GHC.
-In the old scheme this was encoded as a list of 19 chars. This
-gave a size of 77 Bytes, one for the length of the list and 76
-since we encode chars as Word32 as well.
-We can easily do better. The new plan is:
-
-* Start with a tag byte
- * 0 => Int64 (LEB128 encoded)
- * 1 => Negative large integer
- * 2 => Positive large integer
-* Followed by the value:
- * Int64 is encoded as usual
- * Large integers are encoded as a list of bytes (Word8).
- We use Data.Bits which defines a bit order independent of the representation.
- Values are stored LSB first.
-
-This means our example value `2724268014499746065` is now only 10 bytes large.
-* One byte tag
-* One byte for the length of the [Word8] list.
-* 8 bytes for the actual date.
-
-The new scheme also does not depend in any way on
-architecture specific details.
-
-We still use this scheme even with LEB128 available,
-as it has less overhead for truly large numbers. (> maxBound :: Int64)
-
-The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}
instance Binary Integer where
- put_ bh i
- | i >= lo64 && i <= hi64 = do
- putWord8 bh 0
- put_ bh (fromIntegral i :: Int64)
- | otherwise = do
- if i < 0
- then putWord8 bh 1
- else putWord8 bh 2
- put_ bh (unroll $ abs i)
+ -- See Note [Integer serialisation]
+ put_ bh (IS i)
+ = putSLEB128 bh (I# i)
+ put_ bh large_i
+ = putSLEB128 bh large_i
where
- lo64 = fromIntegral (minBound :: Int64)
- hi64 = fromIntegral (maxBound :: Int64)
- get bh = do
- int_kind <- getWord8 bh
- case int_kind of
- 0 -> fromIntegral <$!> (get bh :: IO Int64)
- -- Large integer
- 1 -> negate <$!> getInt
- 2 -> getInt
- _ -> panic "Binary Integer - Invalid byte"
- where
- getInt :: IO Integer
- getInt = roll <$!> (get bh :: IO [Word8])
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
+ get bh = getSLEB128Integer bh
-roll :: [Word8] -> Integer
-roll = foldl' unstep 0 . reverse
+-- | Read an SLEB128 encoded 'Integer'.
+--
+-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
+-- 'Integer' lacks. See Note [Integer serialisation].
+getSLEB128Integer :: ReadBinHandle -> IO Integer
+getSLEB128Integer bh = go_word 0 0
where
- unstep a b = a `shiftL` 8 .|. fromIntegral b
+ -- Accumulate in a Word64 for as long as possible
+ go_word :: Int -> Word64 -> IO Integer
+ go_word !shift !acc = do
+ byte <- getByte bh
+ let !byteVal = clearBit byte 7
+ let more = testBit byte 7
+ let !shift' = shift + 7 -- bits read *after* this step
+ -- Check if the payload still fits in the accumulator,
+ -- if not swap to a Integer accumulator.
+ if shift' <= 64
+ then do
+ let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
+ if more
+ then go_word shift' acc'
+ else return $! signExtendWord shift' acc' (testBit byte 6)
+ else do
+ -- They don't, so from here on out we use Integer arithmetic.
+ let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ go_big :: Int -> Integer -> IO Integer
+ go_big !shift !acc = do
+ byte <- getByte bh
+ let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift + 7
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ -- Sign extend a value of which we read `shift` bits into a Word64.
+ -- `shift` is always <= 64 here, so the result always fits into an Int64.
+ signExtendWord :: Int -> Word64 -> Bool -> Integer
+ signExtendWord !shift !acc signed
+ | not signed
+ = toInteger acc
+ | shift < 64
+ -- set high bits not encoded in the payload
+ = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
+ | otherwise
+ = toInteger (fromIntegral acc :: Int64)
+
+ -- Sign extend into an Integer.
+ signExtendInteger :: Int -> Integer -> Bool -> Integer
+ signExtendInteger !shift !acc signed
+ | signed = acc - (1 `shiftL` shift)
+ | otherwise = acc
{-
=====================================
testsuite/tests/utils/should_run/Binary_Literal.hs
=====================================
@@ -0,0 +1,280 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+-- LLM generated test. So if it's weird it's for no good reason.
+--
+-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
+--
+-- We check that
+-- * arbitrary literals round trip through 'put_' and 'get',
+-- * a whole batch of literals written into one buffer reads back in order,
+-- that is the reader consumes exactly the bytes the writer produced,
+-- * and, since numeric literals carry an 'Integer', that the SLEB128 based
+-- 'Binary Integer' instance agrees with a reference implementation.
+module Main (main) where
+
+import GHC.Data.FastString
+import GHC.Platform ( genericPlatform )
+import GHC.Types.Basic ( FunctionOrData(..) )
+import GHC.Types.Literal
+import GHC.Types.Literal.Floating
+import GHC.Utils.Binary
+
+import Control.Monad ( replicateM )
+import Data.Bits
+import qualified Data.ByteString as BS
+import Data.Ratio ( (%) )
+import Data.Word
+import GHC.Float ( castFloatToWord32, castWord32ToFloat
+ , castDoubleToWord64, castWord64ToDouble )
+import Numeric ( showHex )
+import System.IO.Unsafe ( unsafePerformIO )
+
+import MiniQuickCheck
+
+--------------------------------------------------------------------------------
+-- Encoding and decoding
+
+-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
+-- through a table in the handle's user data. Interface files fill this in with
+-- a deduplication table. We only need something that round trips, so we write
+-- the bytes of the string inline.
+withFastStringWriter :: WriteBinHandle -> WriteBinHandle
+withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
+
+withFastStringReader :: ReadBinHandle -> ReadBinHandle
+withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
+
+-- | Serialise the values and also return the position after the last of them.
+encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
+encodeAll xs = unsafePerformIO $ do
+ bh <- withFastStringWriter <$> openBinMem 1024
+ mapM_ (put_ bh) xs
+ end <- tellBinWriter bh
+ bs <- withBinBuffer bh (return . BS.copy)
+ return (bs, end)
+
+encode :: Binary a => a -> BS.ByteString
+encode x = fst (encodeAll [x])
+
+-- | Read back @n@ values and check that doing so consumed exactly the bytes
+-- the writer produced, no more and no less.
+decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
+decodeAll n (bs, end) = unsafePerformIO $ do
+ bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
+ xs <- replicateM n (get bh)
+ end' <- tellBinReader bh
+ if end' == end
+ then return xs
+ else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
+
+roundTrip :: Binary a => [a] -> [a]
+roundTrip xs = decodeAll (length xs) (encodeAll xs)
+
+roundTrip1 :: Binary a => a -> a
+roundTrip1 x = case roundTrip [x] of
+ [x'] -> x'
+ _ -> error "roundTrip1"
+
+--------------------------------------------------------------------------------
+-- Literals with structural equality and a Show instance
+
+-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
+-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
+-- identifies the different representations of the same value. For a
+-- serialisation test we want the stricter notion.
+newtype Lit = Lit Literal
+
+instance Show Lit where
+ show (Lit l) = showLit l
+
+instance Eq Lit where
+ Lit a == Lit b = eqLit a b
+
+eqLit :: Literal -> Literal -> Bool
+eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
+ = fs1 == fs2 && fod1 == fod2
+eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
+ -- 'Eq LitFloating' compares NaNs bitwise but identifies different
+ -- representations of the same value; the derived 'Show' distinguishes the
+ -- representations but not NaN payloads. Together they compare structurally.
+ = ty1 == ty2 && v1 == v2 && show v1 == show v2
+eqLit a b = a == b
+
+showLit :: Literal -> String
+showLit lit = case lit of
+ LitChar c -> "LitChar " ++ show c
+ LitNumber nt i -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
+ LitString bs -> "LitString " ++ show bs
+ LitNullAddr -> "LitNullAddr"
+ LitRubbish {} -> "LitRubbish"
+ LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
+ LitLabel fs fod -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
+ where
+ -- The bit pattern is needed to tell apart NaNs.
+ bits LitFloat v = "0x" ++ showHex (castFloatToWord32 (litFloatingToHostFloat v)) ""
+ bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
+
+ showFod IsFunction = "IsFunction"
+ showFod IsData = "IsData"
+
+showLitNumType :: LitNumType -> String
+showLitNumType nt = case nt of
+ LitNumBigNat -> "LitNumBigNat"
+ LitNumInt -> "LitNumInt"
+ LitNumInt8 -> "LitNumInt8"
+ LitNumInt16 -> "LitNumInt16"
+ LitNumInt32 -> "LitNumInt32"
+ LitNumInt64 -> "LitNumInt64"
+ LitNumWord -> "LitNumWord"
+ LitNumWord8 -> "LitNumWord8"
+ LitNumWord16 -> "LitNumWord16"
+ LitNumWord32 -> "LitNumWord32"
+ LitNumWord64 -> "LitNumWord64"
+
+--------------------------------------------------------------------------------
+-- Generators
+
+-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
+-- more random ones.
+choose :: Int -> Gen Int
+choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
+
+oneOf :: [Gen a] -> Gen a
+oneOf gens = do
+ i <- choose (length gens)
+ gens !! i
+
+listOf :: Int -> Gen a -> Gen [a]
+listOf maxLen gen = do
+ n <- choose (maxLen + 1)
+ replicateM n gen
+
+-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
+-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
+-- values and values around powers of two.
+genInteger :: Gen Integer
+genInteger = oneOf
+ [ arbitrary
+ , fromIntegral . subtract 300 <$> choose 601
+ , do k <- choose 200
+ d <- subtract 2 <$> choose 5
+ neg <- arbitrary
+ let v = 2 ^ k + toInteger d
+ return (if neg then negate v else v)
+ ]
+
+genLitNumType :: Gen LitNumType
+genLitNumType = oneOf (map pure [LitNumBigNat ..])
+
+-- | Numeric literals are always in range for their type, see
+-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
+-- free to rely on that, so we generate only such literals.
+genLitNumber :: Gen Literal
+genLitNumber = do
+ nt <- genLitNumType
+ i <- genInteger
+ -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
+ -- refuses negative 'BigNat's.
+ let i' | LitNumBigNat <- nt = abs i
+ | otherwise = i
+ return (mkLitNumberWrap genericPlatform nt i')
+
+-- | Random bit patterns, so that we also get infinities, negative zero,
+-- subnormals and NaNs with various payloads.
+genFloat :: Gen Float
+genFloat = castWord32ToFloat <$> arbitrary
+
+genDouble :: Gen Double
+genDouble = castWord64ToDouble <$> arbitrary
+
+genRational :: Gen Rational
+genRational = do
+ n <- genInteger
+ NonZero d <- arbitrary @(NonZero Integer)
+ return (n % d)
+
+genLitFloating :: Gen LitFloating
+genLitFloating = oneOf
+ [ floatToLitFloating <$> genFloat
+ , doubleToLitFloating <$> genDouble
+ , rationalToLitFloating <$> genRational
+ ]
+
+genLitFloatingType :: Gen LitFloatingType
+genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
+
+genByteString :: Gen BS.ByteString
+genByteString = BS.pack <$> listOf 64 arbitrary
+
+genFunctionOrData :: Gen FunctionOrData
+genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
+
+-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
+-- Note [Rubbish literals] in GHC.Types.Literal.
+genLiteral :: Gen Literal
+genLiteral = oneOf
+ [ LitChar <$> arbitrary
+ , genLitNumber
+ , LitString <$> genByteString
+ , pure LitNullAddr
+ , LitFloating <$> genLitFloatingType <*> genLitFloating
+ , LitLabel <$> (mkFastStringByteString <$> genByteString) <*> genFunctionOrData
+ ]
+
+instance Arbitrary Lit where
+ arbitrary = Lit <$> genLiteral
+
+newtype Lits = Lits [Lit]
+ deriving (Eq, Show)
+
+instance Arbitrary Lits where
+ arbitrary = Lits <$> listOf 32 arbitrary
+
+newtype I = I Integer
+ deriving (Eq, Show)
+
+instance Arbitrary I where
+ arbitrary = I <$> genInteger
+
+--------------------------------------------------------------------------------
+-- Properties
+
+-- | Reference implementation of the SLEB128 encoding.
+slebRef :: Integer -> [Word8]
+slebRef = go
+ where
+ go val =
+ let byte = fromIntegral (val .&. 0x7f) :: Word8
+ val' = val `shiftR` 7
+ signBit = testBit byte 6
+ done = (val' == 0 && not signBit) || (val' == -1 && signBit)
+ in if done
+ then [byte]
+ else setBit byte 7 : go val'
+
+prop_literalRoundTrip :: Lit -> PropertyCheck
+prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
+
+prop_literalBatchRoundTrip :: Lits -> PropertyCheck
+prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
+
+prop_integerRoundTrip :: I -> PropertyCheck
+prop_integerRoundTrip (I i) = roundTrip1 i === i
+
+prop_integerEncoding :: I -> PropertyCheck
+prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
+
+tests :: Test
+tests = Group "Binary"
+ [ Group "Literal"
+ [ Property "round trip" prop_literalRoundTrip
+ , Property "batch round trip" prop_literalBatchRoundTrip
+ ]
+ , Group "Integer"
+ [ Property "round trip" prop_integerRoundTrip
+ , Property "SLEB128 encoding" prop_integerEncoding
+ ]
+ ]
+
+main :: IO ()
+main = runTestsMain (Iterations 1000) tests
=====================================
testsuite/tests/utils/should_run/Binary_Literal.stdout
=====================================
@@ -0,0 +1,11 @@
+Group Binary
+ Group Literal
+ Running round trip
+ Passed 1000 iterations
+ Running batch round trip
+ Passed 1000 iterations
+ Group Integer
+ Running round trip
+ Passed 1000 iterations
+ Running SLEB128 encoding
+ Passed 1000 iterations
=====================================
testsuite/tests/utils/should_run/all.T
=====================================
@@ -1 +1,6 @@
test('T15953', [ignore_stdout, js_skip], makefile_test, [])
+
+# Property tests for the 'Binary Literal' instance, which also exercises
+# GHCs 'Binary Integer' instance.
+test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
+ ['Binary_Literal', '-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb587819051dd407d3023ed7c4b7dcf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb587819051dd407d3023ed7c4b7dcf…
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