August 2025 - ghc-commits

[Git][ghc/ghc][wip/spj-apporv-Oct24] 58 commits: refactor: Modify Data.List.sortOn to use (>) instead of compare. (#26184)
by Apoorv Ingle (＠ani) 11 Aug '25

11 Aug '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1f9e4f54 by Stephen Morgan at 2025-08-03T15:14:08+10:00 refactor: Modify Data.List.sortOn to use (>) instead of compare. (#26184) This lets a more efficient (>) operation be used if one exists. This is technically a breaking change for malformed Ord instances, where x > y is not equivalent to compare x y == GT. Discussed by the CLC in issue #332: https://github.com/haskell/core-libraries-committee/issues/332 - - - - - 4f6bc9cf by fendor at 2025-08-04T17:50:06-04:00 Revert "base: Expose Backtraces constructor and fields" This reverts commit 17db44c5b32fff82ea988fa4f1a233d1a27bdf57. - - - - - bcdec657 by Zubin Duggal at 2025-08-05T10:37:29+05:30 compiler: Export a version of `newNameCache` that is not prone to footguns. `newNameCache` must be initialized with both a non-"reserved" unique tag, as well as a list of known key names. Failing to do so results in hard to debug unique conflicts. It is difficult for API users to tell which unique tags are safe to use. So instead of leaving this up to the user to decide, we now export a version of `newNameCache` which uses a guaranteed non-reserved unique tag. In fact, this is now the way the unique tag is initialized for all invocations of the compiler. The original version of `newNameCache` is now exported as `newNameCache'` for advanced users. We also deprecate `initNameCache` as it is also prone to footguns and is completely subsumed in functionality by `newNameCache` and `newNameCache'`. Fixes #26135 and #26055 - - - - - 57d3b4a8 by Andrew Lelechenko at 2025-08-05T18:36:31-04:00 hadrian: bump Stackage snapshot to LTS 24.2 / GHC 9.10.2 In line with #25693 we should use GHC 9.10 as a boot compiler, while Hadrian stack.yaml was stuck on GHC 9.6. - - - - - c2a78cea by Peng Fan at 2025-08-05T18:37:27-04:00 NCG/LA64: implement atomic write with finer-grained DBAR hints Signed-off-by: Peng Fan <fanpeng(a)loongson.cn> - - - - - 95231c8e by Teo Camarasu at 2025-08-06T08:35:58-04:00 CODEOWNERS: add CLC as codeowner of base We also remove hvr, since I think he is no longer active - - - - - 77df0ded by Andrew Lelechenko at 2025-08-06T08:36:39-04:00 Bump submodule text to 2.1.3 - - - - - 8af260d0 by Nikolaos Chatzikonstantinou at 2025-08-06T08:37:23-04:00 docs: fix internal import in getopt examples This external-facing doc example shouldn't mention GHC internals when using 'fromMaybe'. - - - - - 69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00 README: Add note on ghc.nix - - - - - 93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00 Link to the "Strict Bindings" docs from the linear types docs Strict Bidings are relevant for the kinds of multiplicity annotations linear lets support. - - - - - 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00 ipe: Place strings and metadata into specific .ipe section By placing the .ipe metadata into a specific section it can be stripped from the final binary if desired. ``` objcopy --remove-section .ipe <binary> upx <binary> ``` Towards #21766 - - - - - c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Place magic word at the start of entries in the .ipe section The magic word "IPE\nIPE\n" is placed at the start of .ipe sections, then if the section is stripped, we can check whether the section starts with the magic word or not to determine whether there is metadata present or not. Towards #21766 - - - - - cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Use stable IDs for IPE entries IPEs have historically been indexed and reported by their address. This makes it impossible to compare profiles between runs, since the addresses may change (due to ASLR) and also makes it tricky to separate out the IPE map from the binary. This small patch adds a stable identifier for each IPE entry. The stable identifier is a single 64 bit word. The high-bits are a per-module identifier and the low bits identify which entry in each module. 1. When a node is added into the IPE buffer it is assigned a unique identifier from an incrementing global counter. 2. Each entry already has an index by it's position in the `IpeBufferListNode`. The two are combined together by the `IPE_ENTRY_KEY` macro. Info table profiling uses the stable identifier rather than the address of the info table. The benefits of this change are: * Profiles from different runs can be easily compared * The metadata can be extracted from the binary (via the eventlog for example) and then stripped from the executable. Fixes #21766 - - - - - 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00 In TcSShortCut, typechecker plugins should get empty Givens Solving in TcShortCut mode means /ignoring the Givens/. So we should not pass them to typechecker plugins! Fixes #26258. This is a fixup to the earlier MR: commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jul 21 10:04:49 2025 +0100 Improve treatment of SPECIALISE pragmas -- again! - - - - - 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00 Add default QuasiQuoters Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier to write `QuasiQuoters` that give helpful error messages when they're used in inappropriate contexts. Closes #24434. - - - - - 695d6aa8 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed. - Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx` - `tcXExpr` is less hacky now - do not look through HsExpansion applications - kill OrigPat and remove HsThingRn From VAExpansion - look through XExpr ExpandedThingRn while inferring type of head - always set in generated code after stepping inside a ExpandedThingRn - fixing record update error messages - remove special case of tcbody from tcLambdaMatches - wrap last stmt expansion in a HsPar so that the error messages are prettier - remove special case of dsExpr for ExpandedThingTc - make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn - fixing error messages for rebindable - - - - - 4f9b04d2 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs - - - - - f81ef1b9 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 move setQLInstLevel inside tcInstFun - - - - - c920bda7 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 ignore ds warnings originating from gen locations - - - - - 50498466 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 filter expr stmts error msgs - - - - - 6142b89e by Apoorv Ingle at 2025-08-10T11:47:10-05:00 exception for AppDo while making error ctxt - - - - - afcdcc39 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 moving around things for locations and error ctxts - - - - - e6d92598 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements - - - - - 32d4aa90 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 accept test cases with changed error messages ------------------------- Metric Decrease: T9020 ------------------------- - - - - - bbbf717f by Apoorv Ingle at 2025-08-10T11:47:10-05:00 look through PopErrCtxt while splitting exprs in application chains - - - - - a9b52860 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 check the right origin for record selector incomplete warnings - - - - - 4518fb1a by Apoorv Ingle at 2025-08-10T11:47:10-05:00 kill VAExpansion - - - - - ff7c53b1 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - 9802dc8e by Apoorv Ingle at 2025-08-10T11:47:10-05:00 do not suppress pprArising - - - - - 78ce8783 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 kill VACall - - - - - 0b2ff42b by Apoorv Ingle at 2025-08-10T11:47:10-05:00 kill AppCtxt - - - - - e745d321 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 remove addHeadCtxt - - - - - e3055cd3 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 fix pprArising for MonadFailErrors - - - - - eb69d1b0 by Apoorv Ingle at 2025-08-10T11:47:10-05:00 rename ctxt to sloc - - - - - f40490bc by Apoorv Ingle at 2025-08-10T11:47:10-05:00 fix RepPolyDoBind error message herald - - - - - eb8f3bab by Apoorv Ingle at 2025-08-10T11:47:10-05:00 SrcCodeCtxt more changes - - - - - eded19cd by Apoorv Ingle at 2025-08-10T11:47:11-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 7b483c64 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 make error messages for records saner - - - - - 1a864e50 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 accept the right test output - - - - - f932a32e by Apoorv Ingle at 2025-08-10T11:47:11-05:00 make make sure to set inGenerated code for RecordUpdate checks - - - - - 851d9c7f by Apoorv Ingle at 2025-08-10T11:47:11-05:00 rename HsThingRn to SrcCodeOrigin - - - - - 38ae2380 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 minor lclenv getter setter changes - - - - - 55435fcd by Apoorv Ingle at 2025-08-10T11:47:11-05:00 fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin - - - - - a9208611 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 undo test changes - - - - - b509a565 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 fix unused do binding warning error location - - - - - 47a8e1b5 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 FRRRecordUpdate message change - - - - - 972e0d7d by Apoorv Ingle at 2025-08-10T11:47:11-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - f95855f3 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 kill ExpectedFunTyOrig - - - - - 6fa77ee9 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 update argument position number of CtOrigin - - - - - 35a55cc5 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 fix suggestion in error message for record field and modify herald everywhere - - - - - 6dc8f1e0 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 new CtOrigin ExpectedTySyntax - - - - - 8e15ec91 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 more changes to printing origin - - - - - edf7ce71 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 rep poly test case error messages - - - - - e44cd495 by Apoorv Ingle at 2025-08-10T11:47:11-05:00 OrigPat pprCtO says a do statement to mimic DoPatOrigin - - - - - 88473c1a by Apoorv Ingle at 2025-08-10T11:47:11-05:00 remove location from OrigPat - - - - - 111 changed files: - .gitlab/darwin/toolchain.nix - CODEOWNERS - README.md - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Reader.hs - docs/users_guide/debug-info.rst - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/strict.rst - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - hadrian/stack.yaml - hadrian/stack.yaml.lock - libraries/base/changelog.md - libraries/base/src/Control/Exception/Backtrace.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - libraries/text - rts/IPE.c - rts/ProfHeap.c - rts/eventlog/EventLog.c - rts/include/rts/IPE.h - testsuite/tests/default/default-fail05.stderr - testsuite/tests/hiefile/should_run/TestUtils.hs - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T13393.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T24064.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail168.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/569ae5a51a74335fd659e9fe7d933f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/569ae5a51a74335fd659e9fe7d933f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25

10 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: ed38d71b by Cheng Shao at 2025-08-10T14:06:23+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - b7ccecd3 by Cheng Shao at 2025-08-10T14:06:29+00:00 driver: test bytecode roundtrip serialization - - - - - 11 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Breakpoints.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic @@ -929,3 +930,8 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOps !!) <$> get bh + + put_ bh = put_ bh . primOpTag ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -44,6 +45,7 @@ import GHC.HsToCore.Breakpoints import GHC.Iface.Syntax import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Array @@ -297,3 +299,26 @@ instance Outputable CgBreakInfo where parens (ppr (cgb_vars info) <+> ppr (cgb_resty info) <+> ppr (cgb_tick_id info)) + +instance Binary CgBreakInfo where + put_ bh CgBreakInfo {..} = + put_ bh cgb_tyvars + *> put_ bh cgb_vars + *> put_ bh cgb_resty + *> put_ bh cgb_tick_id + + get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh + +instance Binary InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +deriving via BreakpointId instance Binary InternalBreakLoc + +instance Binary InternalBreakpointId where + get bh = InternalBreakpointId <$> get bh <*> get bh + + put_ bh InternalBreakpointId {..} = + put_ bh ibi_info_mod *> put_ bh ibi_info_index ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -0,0 +1,187 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Serialize + ( testBinByteCode, + ) +where + +import Control.Monad +import Data.Binary qualified as Binary +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import GHC.ByteCode.Types +import GHC.Data.FastString +import GHC.Driver.Env +import GHC.Iface.Binary +import GHC.Prelude +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc +import GHC.Utils.Binary +import GHC.Utils.Exception +import GHC.Utils.TmpFs +import System.FilePath + +testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode +testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do + let f = tmpdir </> "ghc-bbc" + roundtripBinByteCode hsc_env f cbc + +roundtripBinByteCode :: + HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode +roundtripBinByteCode hsc_env f cbc = do + writeBinByteCode f cbc + readBinByteCode hsc_env f + +readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode +readBinByteCode hsc_env f = do + bh' <- readBinMem f + bh <- addSerializableNameReader hsc_env bh' + getWithUserData (hsc_NC hsc_env) bh + +writeBinByteCode :: FilePath -> CompiledByteCode -> IO () +writeBinByteCode f cbc = do + bh' <- openBinMem (1024 * 1024) + bh <- addSerializableNameWriter bh' + putWithUserData QuietBinIFace NormalCompression bh cbc + writeBinMem bh f + +instance Binary CompiledByteCode where + get bh = do + bc_bcos <- get bh + bc_itbls_len <- get bh + bc_itbls <- replicateM bc_itbls_len $ do + nm <- getViaSerializableName bh + itbl <- get bh + pure (nm, itbl) + bc_strs_len <- get bh + bc_strs <- + replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh + bc_breaks <- get bh + bc_spt_entries <- get bh + evaluate + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks, + bc_spt_entries + } + + put_ bh CompiledByteCode {..} = do + put_ bh bc_bcos + put_ bh $ length bc_itbls + for_ bc_itbls $ \(nm, itbl) -> do + putViaSerializableName bh nm + put_ bh itbl + put_ bh $ length bc_strs + for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str + put_ bh bc_breaks + put_ bh bc_spt_entries + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaSerializableName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + _ -> BCOPtrBreakArray <$> get bh + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaSerializableName bh + 3 -> BCONPtrAddr <$> getViaSerializableName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + _ -> BCONPtrCostCentre <$> get bh + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +newtype SerializableName = SerializableName {unSerializableName :: Name} + +getViaSerializableName :: ReadBinHandle -> IO Name +getViaSerializableName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unSerializableName <$> f bh + +putViaSerializableName :: WriteBinHandle -> Name -> IO () +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ SerializableName nm + +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle +addSerializableNameWriter bh' = + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh (SerializableName nm) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + put_ bh + $ occNameFS (occName nm) + `appendFS` mkFastString + (show $ nameUnique nm) + +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle +addSerializableNameReader HscEnv {..} bh' = do + nc <- evaluate hsc_NC + env_ref <- newIORef emptyOccEnv + evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + evaluate $ SerializableName nm + _ -> do + occ <- mkVarOccFS <$> get bh + u <- takeUniqFromNameCache nc + nm' <- evaluate $ mkInternalName u occ noSrcSpan + fmap SerializableName $ atomicModifyIORef' env_ref $ \env -> + case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> (extendOccEnv env occ nm', nm') ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.FastString import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry @@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] +instance Binary FFIInfo where + get bh = FFIInfo <$> get bh <*> get bh + + put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet + ===================================== compiler/GHC/Data/FlatBag.hs ===================================== @@ -16,6 +16,8 @@ import GHC.Prelude import Control.DeepSeq import GHC.Data.SmallArray +import GHC.Utils.Binary +import GHC.Utils.Exception -- | Store elements in a flattened representation. -- @@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where rnf (TupleFlatBag a b) = rnf a `seq` rnf b rnf (FlatBag arr) = rnfSmallArray arr +instance (Binary a) => Binary (FlatBag a) where + get bh = do + xs <- get bh + evaluate $ fromList (fromIntegral $ length xs) xs + + put_ bh = put_ bh . elemsFlatBag + -- | Create an empty 'FlatBag'. -- -- The empty 'FlatBag' is shared over all instances. @@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of 1 -> UnitFlatBag (indexSmallArray s 0) 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) _ -> FlatBag s - ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -305,6 +305,8 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import GHC.ByteCode.Serialize + {- ********************************************************************** %* * Initialisation @@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv -> ModLocation -> IO (CompiledByteCode, [FilePath]) generateByteCode hsc_env cgguts mod_location = do - (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location + (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location + comp_bc <- testBinByteCode hsc_env comp_bc' compile_for_interpreter hsc_env $ \ i_env -> do stub_o <- traverse (compileForeign i_env LangC) hasStub foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts) ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import Data.List (intersperse) @@ -106,3 +107,13 @@ The breakpoint is in the function called "baz" that is declared in a `let` or `where` clause of a declaration called "bar", which itself is declared in a `let` or `where` clause of the top-level function called "foo". -} + +instance Binary ModBreaks where + get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + + put_ bh ModBreaks {..} = + put_ bh modBreaks_locs + *> put_ bh modBreaks_vars + *> put_ bh modBreaks_decls + *> put_ bh modBreaks_ccs + *> put_ bh modBreaks_module ===================================== compiler/GHC/Types/SptEntry.hs ===================================== @@ -3,8 +3,12 @@ module GHC.Types.SptEntry ) where -import GHC.Types.Var ( Id ) +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Types.Name import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Prelude +import GHC.Utils.Binary import GHC.Utils.Outputable -- | An entry to be inserted into a module's static pointer table. @@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint instance Outputable SptEntry where ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr +instance Binary SptEntry where + get bh = do + nm <- get bh + fp <- get bh + pure $ SptEntry (mkVanillaGlobal nm anyTy) fp + + put_ bh (SptEntry nm fp) = + put_ bh (getName nm) *> put_ bh fp ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Types.Tickish ( GenTickish(..), @@ -44,6 +45,7 @@ import GHC.Utils.Panic import Language.Haskell.Syntax.Extension ( NoExtField ) import Data.Data +import GHC.Utils.Binary import GHC.Utils.Outputable (Outputable (ppr), text, (<+>)) {- ********************************************************************* @@ -202,6 +204,11 @@ instance NFData BreakpointId where rnf BreakpointId{bi_tick_mod, bi_tick_index} = rnf bi_tick_mod `seq` rnf bi_tick_index +instance Binary BreakpointId where + get bh = BreakpointId <$> get bh <*> get bh + + put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index + -------------------------------------------------------------------------------- -- | A "counting tick" (where tickishCounts is True) is one that ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap +import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt @@ -133,6 +134,8 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI +import GHCi.Message import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -140,8 +143,10 @@ import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe +import qualified Data.Binary as Binary import Data.ByteString (ByteString, copy) import Data.Coerce +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short.Internal as SBS @@ -929,6 +934,12 @@ instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +instance Binary Word where + put_ bh i = put_ bh (fromIntegral i :: Word64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Word64)) + instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do @@ -2106,6 +2117,7 @@ instance Binary BinSrcSpan where _ -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) +deriving via BinSrcSpan instance Binary SrcSpan {- Note [Source Location Wrappers] @@ -2163,3 +2175,40 @@ instance Binary a => Binary (FingerprintWithValue a) where instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () + +instance Binary ConInfoTable where + get bh = Binary.decode . LBS.fromStrict <$> get bh + + put_ bh = put_ bh . LBS.toStrict . Binary.encode + +instance Binary FFIType where + get bh = do + t <- getByte bh + evaluate $ case t of + 0 -> FFIVoid + 1 -> FFIPointer + 2 -> FFIFloat + 3 -> FFIDouble + 4 -> FFISInt8 + 5 -> FFISInt16 + 6 -> FFISInt32 + 7 -> FFISInt64 + 8 -> FFIUInt8 + 9 -> FFIUInt16 + 10 -> FFIUInt32 + 11 -> FFIUInt64 + _ -> panic "Binary FFIType: invalid byte" + + put_ bh t = putByte bh $ case t of + FFIVoid -> 0 + FFIPointer -> 1 + FFIFloat -> 2 + FFIDouble -> 3 + FFISInt8 -> 4 + FFISInt16 -> 5 + FFISInt32 -> 6 + FFISInt64 -> 7 + FFIUInt8 -> 8 + FFIUInt16 -> 9 + FFIUInt32 -> 10 + FFIUInt64 -> 11 ===================================== compiler/ghc.cabal.in ===================================== @@ -228,6 +228,7 @@ Library GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker + GHC.ByteCode.Serialize GHC.ByteCode.Types GHC.Cmm GHC.Cmm.BlockId View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fdebadb57507d452852e1c70fe9472… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fdebadb57507d452852e1c70fe9472… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25

10 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 1362d5a8 by Cheng Shao at 2025-08-10T13:39:51+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - fdebadb5 by Cheng Shao at 2025-08-10T13:39:56+00:00 driver: test bytecode roundtrip serialization - - - - - 10 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Breakpoints.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic @@ -929,3 +930,8 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOps !!) <$> get bh + + put_ bh = put_ bh . primOpTag ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -44,6 +44,7 @@ import GHC.HsToCore.Breakpoints import GHC.Iface.Syntax import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Array @@ -297,3 +298,11 @@ instance Outputable CgBreakInfo where parens (ppr (cgb_vars info) <+> ppr (cgb_resty info) <+> ppr (cgb_tick_id info)) + +deriving newtype instance Binary InternalBreakLoc + +instance Binary InternalBreakpointId where + get bh = InternalBreakpointId <$> get bh <*> get bh + + put_ bh InternalBreakpointId {..} = + put_ bh ibi_info_mod *> put_ bh ibi_info_index ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -0,0 +1,224 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Serialize + ( testBinByteCode, + ) +where + +import Control.Monad +import Data.Binary qualified as Binary +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Types +import GHC.Data.FastString +import GHC.Driver.Env +import GHC.Iface.Binary +import GHC.Prelude +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc +import GHC.Utils.Binary +import GHC.Utils.Exception +import GHC.Utils.TmpFs +import GHCi.Message +import System.FilePath + +testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode +testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do + let f = tmpdir </> "ghc-bbc" + roundtripBinByteCode hsc_env f cbc + +roundtripBinByteCode :: + HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode +roundtripBinByteCode hsc_env f cbc = do + writeBinByteCode f cbc + readBinByteCode hsc_env f + +readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode +readBinByteCode hsc_env f = do + bh' <- readBinMem f + bh <- addSerializableNameReader hsc_env bh' + getWithUserData (hsc_NC hsc_env) bh + +writeBinByteCode :: FilePath -> CompiledByteCode -> IO () +writeBinByteCode f cbc = do + bh' <- openBinMem (1024 * 1024) + bh <- addSerializableNameWriter bh' + putWithUserData QuietBinIFace NormalCompression bh cbc + writeBinMem bh f + +instance Binary CompiledByteCode where + get bh = do + bc_bcos <- get bh + bc_itbls_len <- get bh + bc_itbls <- replicateM bc_itbls_len $ do + nm <- getViaSerializableName bh + itbl <- get bh + pure (nm, itbl) + bc_strs_len <- get bh + bc_strs <- + replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh + bc_breaks <- get bh + bc_spt_entries <- get bh + evaluate + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks, + bc_spt_entries + } + + put_ bh CompiledByteCode {..} = do + put_ bh bc_bcos + put_ bh $ length bc_itbls + for_ bc_itbls $ \(nm, itbl) -> do + putViaSerializableName bh nm + put_ bh itbl + put_ bh $ length bc_strs + for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str + put_ bh bc_breaks + put_ bh bc_spt_entries + +instance Binary InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +instance Binary ModBreaks where + get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + + put_ bh ModBreaks {..} = + put_ bh modBreaks_locs + *> put_ bh modBreaks_vars + *> put_ bh modBreaks_decls + *> put_ bh modBreaks_ccs + *> put_ bh modBreaks_module + +instance Binary SrcSpan where + get bh = unBinSrcSpan <$> get bh + + put_ bh = put_ bh . BinSrcSpan + +instance Binary CgBreakInfo where + put_ bh CgBreakInfo {..} = + put_ bh cgb_tyvars + *> put_ bh cgb_vars + *> put_ bh cgb_resty + *> put_ bh cgb_tick_id + + get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh + +instance Binary ConInfoTable where + get bh = Binary.decode . LBS.fromStrict <$> get bh + + put_ bh = put_ bh . LBS.toStrict . Binary.encode + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaSerializableName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + _ -> BCOPtrBreakArray <$> get bh + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaSerializableName bh + 3 -> BCONPtrAddr <$> getViaSerializableName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + _ -> BCONPtrCostCentre <$> get bh + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +newtype SerializableName = SerializableName {unSerializableName :: Name} + +getViaSerializableName :: ReadBinHandle -> IO Name +getViaSerializableName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unSerializableName <$> f bh + +putViaSerializableName :: WriteBinHandle -> Name -> IO () +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ SerializableName nm + +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle +addSerializableNameWriter bh' = + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh (SerializableName nm) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + put_ bh + $ occNameFS (occName nm) + `appendFS` mkFastString + (show $ nameUnique nm) + +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle +addSerializableNameReader HscEnv {..} bh' = do + nc <- evaluate hsc_NC + env_ref <- newIORef emptyOccEnv + evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + evaluate $ SerializableName nm + _ -> do + occ <- mkVarOccFS <$> get bh + u <- takeUniqFromNameCache nc + nm' <- evaluate $ mkInternalName u occ noSrcSpan + fmap SerializableName $ atomicModifyIORef' env_ref $ \env -> + case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> (extendOccEnv env occ nm', nm') ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.FastString import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry @@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] +instance Binary FFIInfo where + get bh = FFIInfo <$> get bh <*> get bh + + put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet + ===================================== compiler/GHC/Data/FlatBag.hs ===================================== @@ -16,6 +16,8 @@ import GHC.Prelude import Control.DeepSeq import GHC.Data.SmallArray +import GHC.Utils.Binary +import GHC.Utils.Exception -- | Store elements in a flattened representation. -- @@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where rnf (TupleFlatBag a b) = rnf a `seq` rnf b rnf (FlatBag arr) = rnfSmallArray arr +instance (Binary a) => Binary (FlatBag a) where + get bh = do + xs <- get bh + evaluate $ fromList (fromIntegral $ length xs) xs + + put_ bh = put_ bh . elemsFlatBag + -- | Create an empty 'FlatBag'. -- -- The empty 'FlatBag' is shared over all instances. @@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of 1 -> UnitFlatBag (indexSmallArray s 0) 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) _ -> FlatBag s - ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -305,6 +305,8 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import GHC.ByteCode.Serialize + {- ********************************************************************** %* * Initialisation @@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv -> ModLocation -> IO (CompiledByteCode, [FilePath]) generateByteCode hsc_env cgguts mod_location = do - (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location + (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location + comp_bc <- testBinByteCode hsc_env comp_bc' compile_for_interpreter hsc_env $ \ i_env -> do stub_o <- traverse (compileForeign i_env LangC) hasStub foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts) ===================================== compiler/GHC/Types/SptEntry.hs ===================================== @@ -3,8 +3,12 @@ module GHC.Types.SptEntry ) where -import GHC.Types.Var ( Id ) +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Types.Name import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Prelude +import GHC.Utils.Binary import GHC.Utils.Outputable -- | An entry to be inserted into a module's static pointer table. @@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint instance Outputable SptEntry where ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr +instance Binary SptEntry where + get bh = do + nm <- get bh + fp <- get bh + pure $ SptEntry (mkVanillaGlobal nm anyTy) fp + + put_ bh (SptEntry nm fp) = + put_ bh (getName nm) *> put_ bh fp ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Types.Tickish ( GenTickish(..), @@ -44,6 +45,7 @@ import GHC.Utils.Panic import Language.Haskell.Syntax.Extension ( NoExtField ) import Data.Data +import GHC.Utils.Binary import GHC.Utils.Outputable (Outputable (ppr), text, (<+>)) {- ********************************************************************* @@ -202,6 +204,11 @@ instance NFData BreakpointId where rnf BreakpointId{bi_tick_mod, bi_tick_index} = rnf bi_tick_mod `seq` rnf bi_tick_index +instance Binary BreakpointId where + get bh = BreakpointId <$> get bh <*> get bh + + put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index + -------------------------------------------------------------------------------- -- | A "counting tick" (where tickishCounts is True) is one that ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap +import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt @@ -133,6 +134,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -929,6 +931,12 @@ instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +instance Binary Word where + put_ bh i = put_ bh (fromIntegral i :: Word64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Word64)) + instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do @@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () + +instance Binary FFIType where + get bh = do + t <- getByte bh + evaluate $ case t of + 0 -> FFIVoid + 1 -> FFIPointer + 2 -> FFIFloat + 3 -> FFIDouble + 4 -> FFISInt8 + 5 -> FFISInt16 + 6 -> FFISInt32 + 7 -> FFISInt64 + 8 -> FFIUInt8 + 9 -> FFIUInt16 + 10 -> FFIUInt32 + 11 -> FFIUInt64 + _ -> panic "Binary FFIType: invalid byte" + + put_ bh t = putByte bh $ case t of + FFIVoid -> 0 + FFIPointer -> 1 + FFIFloat -> 2 + FFIDouble -> 3 + FFISInt8 -> 4 + FFISInt16 -> 5 + FFISInt32 -> 6 + FFISInt64 -> 7 + FFIUInt8 -> 8 + FFIUInt16 -> 9 + FFIUInt32 -> 10 + FFIUInt64 -> 11 ===================================== compiler/ghc.cabal.in ===================================== @@ -228,6 +228,7 @@ Library GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker + GHC.ByteCode.Serialize GHC.ByteCode.Types GHC.Cmm GHC.Cmm.BlockId View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25

10 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: d9a91519 by Cheng Shao at 2025-08-10T13:18:32+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - e1707f1c by Cheng Shao at 2025-08-10T13:18:37+00:00 driver: test bytecode roundtrip serialization - - - - - 8 changed files: - compiler/GHC/Builtin/PrimOps.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic @@ -929,3 +930,8 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOps !!) <$> get bh + + put_ bh = put_ bh . primOpTag ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -0,0 +1,240 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Serialize + ( testBinByteCode, + ) +where + +import Control.Monad +import Data.Binary qualified as Binary +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Types +import GHC.Data.FastString +import GHC.Driver.Env +import GHC.Iface.Binary +import GHC.Prelude +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc +import GHC.Utils.Binary +import GHC.Utils.Exception +import GHC.Utils.TmpFs +import GHCi.Message +import System.FilePath + +testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode +testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do + let f = tmpdir </> "ghc-bbc" + roundtripBinByteCode hsc_env f cbc + +roundtripBinByteCode :: + HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode +roundtripBinByteCode hsc_env f cbc = do + writeBinByteCode f cbc + readBinByteCode hsc_env f + +readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode +readBinByteCode hsc_env f = do + bh' <- readBinMem f + bh <- addSerializableNameReader hsc_env bh' + getWithUserData (hsc_NC hsc_env) bh + +writeBinByteCode :: FilePath -> CompiledByteCode -> IO () +writeBinByteCode f cbc = do + bh' <- openBinMem (1024 * 1024) + bh <- addSerializableNameWriter bh' + putWithUserData QuietBinIFace NormalCompression bh cbc + writeBinMem bh f + +instance Binary CompiledByteCode where + get bh = do + bc_bcos <- get bh + bc_itbls_len <- get bh + bc_itbls <- replicateM bc_itbls_len $ do + nm <- getViaSerializableName bh + itbl <- get bh + pure (nm, itbl) + bc_strs_len <- get bh + bc_strs <- + replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh + bc_breaks <- get bh + bc_spt_entries <- get bh + evaluate + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks, + bc_spt_entries + } + + put_ bh CompiledByteCode {..} = do + put_ bh bc_bcos + put_ bh $ length bc_itbls + for_ bc_itbls $ \(nm, itbl) -> do + putViaSerializableName bh nm + put_ bh itbl + put_ bh $ length bc_strs + for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str + put_ bh bc_breaks + put_ bh bc_spt_entries + +instance Binary InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +instance Binary ModBreaks where + get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + + put_ bh ModBreaks {..} = + put_ bh modBreaks_locs + *> put_ bh modBreaks_vars + *> put_ bh modBreaks_decls + *> put_ bh modBreaks_ccs + *> put_ bh modBreaks_module + +instance Binary SrcSpan where + get bh = unBinSrcSpan <$> get bh + + put_ bh = put_ bh . BinSrcSpan + +instance Binary CgBreakInfo where + put_ bh CgBreakInfo {..} = + put_ bh cgb_tyvars + *> put_ bh cgb_vars + *> put_ bh cgb_resty + *> put_ bh cgb_tick_id + + get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh + +instance Binary ConInfoTable where + get bh = Binary.decode . LBS.fromStrict <$> get bh + + put_ bh = put_ bh . LBS.toStrict . Binary.encode + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaSerializableName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + _ -> BCOPtrBreakArray <$> get bh + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaSerializableName bh + 3 -> BCONPtrAddr <$> getViaSerializableName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + _ -> BCONPtrCostCentre <$> get bh + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +instance Binary InternalBreakLoc where + get bh = InternalBreakLoc <$> get bh + + put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc + +instance Binary BreakpointId where + get bh = BreakpointId <$> get bh <*> get bh + + put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index + +instance Binary InternalBreakpointId where + get bh = InternalBreakpointId <$> get bh <*> get bh + + put_ bh InternalBreakpointId {..} = + put_ bh ibi_info_mod *> put_ bh ibi_info_index + +newtype SerializableName = SerializableName {unSerializableName :: Name} + +getViaSerializableName :: ReadBinHandle -> IO Name +getViaSerializableName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unSerializableName <$> f bh + +putViaSerializableName :: WriteBinHandle -> Name -> IO () +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ SerializableName nm + +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle +addSerializableNameWriter bh' = + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh (SerializableName nm) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + put_ bh + $ occNameFS (occName nm) + `appendFS` mkFastString + (show $ nameUnique nm) + +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle +addSerializableNameReader HscEnv {..} bh' = do + nc <- evaluate hsc_NC + env_ref <- newIORef emptyOccEnv + evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + evaluate $ SerializableName nm + _ -> do + occ <- mkVarOccFS <$> get bh + u <- takeUniqFromNameCache nc + nm' <- evaluate $ mkInternalName u occ noSrcSpan + fmap SerializableName $ atomicModifyIORef' env_ref $ \env -> + case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> (extendOccEnv env occ nm', nm') ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.FastString import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry @@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] +instance Binary FFIInfo where + get bh = FFIInfo <$> get bh <*> get bh + + put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet + ===================================== compiler/GHC/Data/FlatBag.hs ===================================== @@ -16,6 +16,8 @@ import GHC.Prelude import Control.DeepSeq import GHC.Data.SmallArray +import GHC.Utils.Binary +import GHC.Utils.Exception -- | Store elements in a flattened representation. -- @@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where rnf (TupleFlatBag a b) = rnf a `seq` rnf b rnf (FlatBag arr) = rnfSmallArray arr +instance (Binary a) => Binary (FlatBag a) where + get bh = do + xs <- get bh + evaluate $ fromList (fromIntegral $ length xs) xs + + put_ bh = put_ bh . elemsFlatBag + -- | Create an empty 'FlatBag'. -- -- The empty 'FlatBag' is shared over all instances. @@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of 1 -> UnitFlatBag (indexSmallArray s 0) 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) _ -> FlatBag s - ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -305,6 +305,8 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import GHC.ByteCode.Serialize + {- ********************************************************************** %* * Initialisation @@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv -> ModLocation -> IO (CompiledByteCode, [FilePath]) generateByteCode hsc_env cgguts mod_location = do - (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location + (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location + comp_bc <- testBinByteCode hsc_env comp_bc' compile_for_interpreter hsc_env $ \ i_env -> do stub_o <- traverse (compileForeign i_env LangC) hasStub foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts) ===================================== compiler/GHC/Types/SptEntry.hs ===================================== @@ -3,8 +3,12 @@ module GHC.Types.SptEntry ) where -import GHC.Types.Var ( Id ) +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Types.Name import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Prelude +import GHC.Utils.Binary import GHC.Utils.Outputable -- | An entry to be inserted into a module's static pointer table. @@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint instance Outputable SptEntry where ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr +instance Binary SptEntry where + get bh = do + nm <- get bh + fp <- get bh + pure $ SptEntry (mkVanillaGlobal nm anyTy) fp + + put_ bh (SptEntry nm fp) = + put_ bh (getName nm) *> put_ bh fp ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap +import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt @@ -133,6 +134,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -929,6 +931,12 @@ instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +instance Binary Word where + put_ bh i = put_ bh (fromIntegral i :: Word64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Word64)) + instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do @@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () + +instance Binary FFIType where + get bh = do + t <- getByte bh + evaluate $ case t of + 0 -> FFIVoid + 1 -> FFIPointer + 2 -> FFIFloat + 3 -> FFIDouble + 4 -> FFISInt8 + 5 -> FFISInt16 + 6 -> FFISInt32 + 7 -> FFISInt64 + 8 -> FFIUInt8 + 9 -> FFIUInt16 + 10 -> FFIUInt32 + 11 -> FFIUInt64 + _ -> panic "Binary FFIType: invalid byte" + + put_ bh t = putByte bh $ case t of + FFIVoid -> 0 + FFIPointer -> 1 + FFIFloat -> 2 + FFIDouble -> 3 + FFISInt8 -> 4 + FFISInt16 -> 5 + FFISInt32 -> 6 + FFISInt64 -> 7 + FFIUInt8 -> 8 + FFIUInt16 -> 9 + FFIUInt32 -> 10 + FFIUInt64 -> 11 ===================================== compiler/ghc.cabal.in ===================================== @@ -228,6 +228,7 @@ Library GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker + GHC.ByteCode.Serialize GHC.ByteCode.Types GHC.Cmm GHC.Cmm.BlockId View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25

10 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: bca57385 by Cheng Shao at 2025-08-10T13:06:05+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - c9eb4883 by Cheng Shao at 2025-08-10T13:06:11+00:00 driver: test bytecode roundtrip serialization - - - - - 7 changed files: - compiler/GHC/Builtin/PrimOps.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic @@ -929,3 +930,8 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOps !!) <$> get bh + + put_ bh = put_ bh . primOpTag ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -0,0 +1,252 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Serialize + ( testBinByteCode, + ) +where + +import Control.Monad +import Data.Binary qualified as Binary +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import GHC.Builtin.Types +import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Types +import GHC.Data.FastString +import GHC.Driver.Env +import GHC.Iface.Binary +import GHC.Prelude +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.SptEntry +import GHC.Types.SrcLoc +import GHC.Utils.Binary +import GHC.Utils.Exception +import GHC.Utils.TmpFs +import GHCi.Message +import System.FilePath + +testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode +testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do + let f = tmpdir </> "ghc-bbc" + roundtripBinByteCode hsc_env f cbc + +roundtripBinByteCode :: + HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode +roundtripBinByteCode hsc_env f cbc = do + writeBinByteCode f cbc + readBinByteCode hsc_env f + +readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode +readBinByteCode hsc_env f = do + bh' <- readBinMem f + bh <- addSerializableNameReader hsc_env bh' + getWithUserData (hsc_NC hsc_env) bh + +writeBinByteCode :: FilePath -> CompiledByteCode -> IO () +writeBinByteCode f cbc = do + bh' <- openBinMem (1024 * 1024) + bh <- addSerializableNameWriter bh' + putWithUserData QuietBinIFace NormalCompression bh cbc + writeBinMem bh f + +instance Binary CompiledByteCode where + get bh = do + bc_bcos <- get bh + bc_itbls_len <- get bh + bc_itbls <- replicateM bc_itbls_len $ do + nm <- getViaSerializableName bh + itbl <- get bh + pure (nm, itbl) + bc_strs_len <- get bh + bc_strs <- + replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh + bc_breaks <- get bh + bc_spt_entries <- get bh + evaluate + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks, + bc_spt_entries + } + + put_ bh CompiledByteCode {..} = do + put_ bh bc_bcos + put_ bh $ length bc_itbls + for_ bc_itbls $ \(nm, itbl) -> do + putViaSerializableName bh nm + put_ bh itbl + put_ bh $ length bc_strs + for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str + put_ bh bc_breaks + put_ bh bc_spt_entries + +instance Binary InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +instance Binary ModBreaks where + get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + + put_ bh ModBreaks {..} = + put_ bh modBreaks_locs + *> put_ bh modBreaks_vars + *> put_ bh modBreaks_decls + *> put_ bh modBreaks_ccs + *> put_ bh modBreaks_module + +instance Binary SrcSpan where + get bh = unBinSrcSpan <$> get bh + + put_ bh = put_ bh . BinSrcSpan + +instance Binary CgBreakInfo where + put_ bh CgBreakInfo {..} = + put_ bh cgb_tyvars + *> put_ bh cgb_vars + *> put_ bh cgb_resty + *> put_ bh cgb_tick_id + + get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh + +instance Binary ConInfoTable where + get bh = Binary.decode . LBS.fromStrict <$> get bh + + put_ bh = put_ bh . LBS.toStrict . Binary.encode + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaSerializableName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + _ -> BCOPtrBreakArray <$> get bh + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaSerializableName bh + 3 -> BCONPtrAddr <$> getViaSerializableName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + _ -> BCONPtrCostCentre <$> get bh + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +instance Binary InternalBreakLoc where + get bh = InternalBreakLoc <$> get bh + + put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc + +instance Binary BreakpointId where + get bh = BreakpointId <$> get bh <*> get bh + + put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index + +instance Binary InternalBreakpointId where + get bh = InternalBreakpointId <$> get bh <*> get bh + + put_ bh InternalBreakpointId {..} = + put_ bh ibi_info_mod *> put_ bh ibi_info_index + +instance Binary SptEntry where + get bh = do + nm <- getViaSerializableName bh + fp <- get bh + pure $ SptEntry (mkVanillaGlobal nm anyTy) fp + + put_ bh (SptEntry nm fp) = + putViaSerializableName bh (getName nm) *> put_ bh fp + +newtype SerializableName = SerializableName {unSerializableName :: Name} + +getViaSerializableName :: ReadBinHandle -> IO Name +getViaSerializableName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unSerializableName <$> f bh + +putViaSerializableName :: WriteBinHandle -> Name -> IO () +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ SerializableName nm + +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle +addSerializableNameWriter bh' = + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh (SerializableName nm) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + put_ bh + $ occNameFS (occName nm) + `appendFS` mkFastString + (show $ nameUnique nm) + +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle +addSerializableNameReader HscEnv {..} bh' = do + nc <- evaluate hsc_NC + env_ref <- newIORef emptyOccEnv + evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + evaluate $ SerializableName nm + _ -> do + occ <- mkVarOccFS <$> get bh + u <- takeUniqFromNameCache nc + nm' <- evaluate $ mkInternalName u occ noSrcSpan + fmap SerializableName $ atomicModifyIORef' env_ref $ \env -> + case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> (extendOccEnv env occ nm', nm') ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.FastString import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry @@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] +instance Binary FFIInfo where + get bh = FFIInfo <$> get bh <*> get bh + + put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet + ===================================== compiler/GHC/Data/FlatBag.hs ===================================== @@ -16,6 +16,8 @@ import GHC.Prelude import Control.DeepSeq import GHC.Data.SmallArray +import GHC.Utils.Binary +import GHC.Utils.Exception -- | Store elements in a flattened representation. -- @@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where rnf (TupleFlatBag a b) = rnf a `seq` rnf b rnf (FlatBag arr) = rnfSmallArray arr +instance (Binary a) => Binary (FlatBag a) where + get bh = do + xs <- get bh + evaluate $ fromList (fromIntegral $ length xs) xs + + put_ bh = put_ bh . elemsFlatBag + -- | Create an empty 'FlatBag'. -- -- The empty 'FlatBag' is shared over all instances. @@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of 1 -> UnitFlatBag (indexSmallArray s 0) 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) _ -> FlatBag s - ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -305,6 +305,8 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import GHC.ByteCode.Serialize + {- ********************************************************************** %* * Initialisation @@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv -> ModLocation -> IO (CompiledByteCode, [FilePath]) generateByteCode hsc_env cgguts mod_location = do - (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location + (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location + comp_bc <- testBinByteCode hsc_env comp_bc' compile_for_interpreter hsc_env $ \ i_env -> do stub_o <- traverse (compileForeign i_env LangC) hasStub foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts) ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap +import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt @@ -133,6 +134,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -929,6 +931,12 @@ instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +instance Binary Word where + put_ bh i = put_ bh (fromIntegral i :: Word64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Word64)) + instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do @@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () + +instance Binary FFIType where + get bh = do + t <- getByte bh + evaluate $ case t of + 0 -> FFIVoid + 1 -> FFIPointer + 2 -> FFIFloat + 3 -> FFIDouble + 4 -> FFISInt8 + 5 -> FFISInt16 + 6 -> FFISInt32 + 7 -> FFISInt64 + 8 -> FFIUInt8 + 9 -> FFIUInt16 + 10 -> FFIUInt32 + 11 -> FFIUInt64 + _ -> panic "Binary FFIType: invalid byte" + + put_ bh t = putByte bh $ case t of + FFIVoid -> 0 + FFIPointer -> 1 + FFIFloat -> 2 + FFIDouble -> 3 + FFISInt8 -> 4 + FFISInt16 -> 5 + FFISInt32 -> 6 + FFISInt64 -> 7 + FFIUInt8 -> 8 + FFIUInt16 -> 9 + FFIUInt32 -> 10 + FFIUInt64 -> 11 ===================================== compiler/ghc.cabal.in ===================================== @@ -228,6 +228,7 @@ Library GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker + GHC.ByteCode.Serialize GHC.ByteCode.Types GHC.Cmm GHC.Cmm.BlockId View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 16 commits: level imports: Check the level of exported identifiers
by Cheng Shao (＠TerrorJack) 10 Aug '25

10 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00 ipe: Place strings and metadata into specific .ipe section By placing the .ipe metadata into a specific section it can be stripped from the final binary if desired. ``` objcopy --remove-section .ipe <binary> upx <binary> ``` Towards #21766 - - - - - c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Place magic word at the start of entries in the .ipe section The magic word "IPE\nIPE\n" is placed at the start of .ipe sections, then if the section is stripped, we can check whether the section starts with the magic word or not to determine whether there is metadata present or not. Towards #21766 - - - - - cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Use stable IDs for IPE entries IPEs have historically been indexed and reported by their address. This makes it impossible to compare profiles between runs, since the addresses may change (due to ASLR) and also makes it tricky to separate out the IPE map from the binary. This small patch adds a stable identifier for each IPE entry. The stable identifier is a single 64 bit word. The high-bits are a per-module identifier and the low bits identify which entry in each module. 1. When a node is added into the IPE buffer it is assigned a unique identifier from an incrementing global counter. 2. Each entry already has an index by it's position in the `IpeBufferListNode`. The two are combined together by the `IPE_ENTRY_KEY` macro. Info table profiling uses the stable identifier rather than the address of the info table. The benefits of this change are: * Profiles from different runs can be easily compared * The metadata can be extracted from the binary (via the eventlog for example) and then stripped from the executable. Fixes #21766 - - - - - 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00 In TcSShortCut, typechecker plugins should get empty Givens Solving in TcShortCut mode means /ignoring the Givens/. So we should not pass them to typechecker plugins! Fixes #26258. This is a fixup to the earlier MR: commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jul 21 10:04:49 2025 +0100 Improve treatment of SPECIALISE pragmas -- again! - - - - - 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00 Add default QuasiQuoters Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier to write `QuasiQuoters` that give helpful error messages when they're used in inappropriate contexts. Closes #24434. - - - - - 9bf81834 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00 cleanup: Move dehydrateCgBreakInfo to Stg2Bc This no longer has anything to do with Core. - - - - - d6335551 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00 rts/Disassembler: Fix spacing of BRK_FUN - - - - - 4dd9b18b by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00 debugger: Fix bciPtr in Step-out We need to use `BCO_NEXT` to move bciPtr to ix=1, because ix=0 points to the instruction itself! I do not understand how this didn't crash before. - - - - - a75fafd4 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00 debugger: Allow BRK_FUNs to head case continuation BCOs When we start executing a BCO, we may want to yield to the scheduler: this may be triggered by a heap/stack check, context switch, or a breakpoint. To yield, we need to put the stack in a state such that when execution is resumed we are back to where we yielded from. Previously, a BKR_FUN could only head a function BCO because we only knew how to construct a valid stack for yielding from one -- simply add `apply_interp_info` + the BCO to resume executing. This is valid because the stack at the start of run_BCO is headed by that BCO's arguments. However, in case continuation BCOs (as per Note [Case continuation BCOs]), we couldn't easily reconstruct a valid stack that could be resumed because we dropped too soon the stack frames regarding the value returned (stg_ret) and received (stg_ctoi) by that continuation. This is especially tricky because of the variable type and size return frames (e.g. pointer ret_p/ctoi_R1p vs a tuple ret_t/ctoi_t2). The trick to being able to yield from a BRK_FUN at the start of a case cont BCO is to stop removing the ret frame headers eagerly and instead keep them until the BCO starts executing. The new layout at the start of a case cont. BCO is described by the new Note [Stack layout when entering run_BCO]. Now, we keep the ret_* and ctoi_* frames when entering run_BCO. A BRK_FUN is then executed if found, and the stack is yielded as-is with the preserved ret and ctoi frames. Then, a case cont BCO's instructions always SLIDE off the headers of the ret and ctoi frames, in StgToByteCode.doCase, turning a stack like | .... | +---------------+ | fv2 | +---------------+ | fv1 | +---------------+ | BCO | +---------------+ | stg_ctoi_ret_ | +---------------+ | retval | +---------------+ | stg_ret_..... | +---------------+ into | .... | +---------------+ | fv2 | +---------------+ | fv1 | +---------------+ | retval | +---------------+ for the remainder of the BCO. Moreover, this more uniform approach of keeping the ret and ctoi frames means we need less ad-hoc logic concerning the variable size of ret_tuple vs ret_p/np frames in the code generator and interpreter: Always keep the return to cont. stack intact at the start of run_BCO, and the statically generated instructions will take care of adjusting it. Unlocks BRK_FUNs at the start of case cont. BCOs which will enable a better user-facing step-out (#26042) which is free of the bugs the current BRK_ALTS implementation suffers from (namely, using BRK_FUN rather than BRK_ALTS in a case cont. means we'll never accidentally end up in a breakpoint "deeper" than the continuation, because we stop at the case cont itself rather than on the first breakpoint we evaluate after it). - - - - - f03ef9d3 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00 BRK_FUN with InternalBreakLocs for code-generation time breakpoints At the start of a case continuation BCO, place a BRK_FUN. This BRK_FUN uses the new "internal breakpoint location" -- allowing us to come up with a valid source location for this breakpoint that is not associated with a source-level tick. For case continuation BCOs, we use the last tick seen before it as the source location. The reasoning is described in Note [Debugger: Stepout internal break locs]. Note how T26042c, which was broken because it displayed the incorrect behavior of the previous step out when we'd end up at a deeper level than the one from which we initiated step-out, is now fixed. As of this commit, BRK_ALTS is now dead code and is thus dropped. Note [Debugger: Stepout internal break locs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Step-out tells the interpreter to run until the current function returns to where it was called from, and stop there. This is achieved by enabling the BRK_FUN found on the first RET_BCO frame on the stack (See [Note Debugger: Step-out]). Case continuation BCOs (which select an alternative branch) must therefore be headed by a BRK_FUN. An example: f x = case g x of <--- end up here 1 -> ... 2 -> ... g y = ... <--- step out from here - `g` will return a value to the case continuation BCO in `f` - The case continuation BCO will receive the value returned from g - Match on it and push the alternative continuation for that branch - And then enter that alternative. If we step-out of `g`, the first RET_BCO on the stack is the case continuation of `f` -- execution should stop at its start, before selecting an alternative. (One might ask, "why not enable the breakpoint in the alternative instead?", because the alternative continuation is only pushed to the stack *after* it is selected by the case cont. BCO) However, the case cont. BCO is not associated with any source-level tick, it is merely the glue code which selects alternatives which do have source level ticks. Therefore, we have to come up at code generation time with a breakpoint location ('InternalBreakLoc') to display to the user when it is stopped there. Our solution is to use the last tick seen just before reaching the case continuation. This is robust because a case continuation will thus always have a relevant breakpoint location: - The source location will be the last source-relevant expression executed before the continuation is pushed - So the source location will point to the thing you've just stepped out of - Doing :step-local from there will put you on the selected alternative (which at the source level may also be the e.g. next line in a do-block) Examples, using angle brackets (<<...>>) to denote the breakpoint span: f x = case <<g x>> {- step in here -} of 1 -> ... 2 -> ...> g y = <<...>> <--- step out from here ... f x = <<case g x of <--- end up here, whole case highlighted 1 -> ... 2 -> ...>> doing :step-local ... f x = case g x of 1 -> <<...>> <--- stop in the alternative 2 -> ... A second example based on T26042d2, where the source is a do-block IO action, optimised to a chain of `case expressions`. main = do putStrLn "hello1" <<f>> <--- step-in here putStrLn "hello3" putStrLn "hello4" f = do <<putStrLn "hello2.1">> <--- step-out from here putStrLn "hello2.2" ... main = do putStrLn "hello1" <<f>> <--- end up here again, the previously executed expression putStrLn "hello3" putStrLn "hello4" doing step/step-local ... main = do putStrLn "hello1" f <<putStrLn "hello3">> <--- straight to the next line putStrLn "hello4" Finishes #26042 - - - - - 52ba24df by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00 debugger: Re-use the last BreakpointId whole in step-out Previously, to come up with a location to stop at for `:stepout`, we would store the location of the last BreakpointId surrounding the continuation, as described by Note [Debugger: Stepout internal break locs]. However, re-using just the location from the last source breakpoint isn't sufficient to provide the necessary information in the break location. Specifically, it wouldn't bind any variables at that location. Really, there is no reason not to re-use the last breakpoint wholesale, and re-use all the information we had there. Step-out should behave just as if we had stopped at the call, but s.t. continuing will not re-execute the call. This commit updates the CgBreakInfo to always store a BreakpointId, be it the original one or the one we're emulating (for step-out). It makes variable bindings on :stepout work - - - - - 0fe77f20 by Cheng Shao at 2025-08-10T11:18:27+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - 759209ae by Cheng Shao at 2025-08-10T11:18:27+00:00 driver: test bytecode roundtrip serialization - - - - - 72 changed files: - .gitlab/darwin/toolchain.nix - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - ghc/GHCi/UI.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/ghci/GHCi/Run.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - rts/Disassembler.c - rts/IPE.c - rts/Interpreter.c - rts/ProfHeap.c - rts/Profiling.c - rts/eventlog/EventLog.c - rts/include/rts/Bytecodes.h - rts/include/rts/IPE.h - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/ghci.debugger/scripts/T26042b.script - testsuite/tests/ghci.debugger/scripts/T26042b.stdout - testsuite/tests/ghci.debugger/scripts/T26042c.script - testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d2.hs - + testsuite/tests/ghci.debugger/scripts/T26042d2.script - + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout - testsuite/tests/ghci.debugger/scripts/T26042e.stdout - testsuite/tests/ghci.debugger/scripts/T26042f.script - testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] Remove JSON logging
by Simon Hengel (＠sol) 10 Aug '25

10 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 611f3f3b by Simon Hengel at 2025-08-10T10:12:54+07:00 Remove JSON logging - - - - - 7 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -368,7 +368,7 @@ msg msg = do name_ppr_ctx <- getNamePprCtx let m = case msg of MCDump doc -> MCDump (dump_sty doc) - MCDiagnostic span severity reason code doc -> UnsafeMCDiagnostic span severity reason code (err_sty doc) + UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic MCOutput doc -> MCOutput (user_sty doc) MCFatal doc -> MCFatal (user_sty doc) MCInteractive doc -> MCInteractive (user_sty doc) ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -47,18 +47,15 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () printMessage logger msg_opts opts message = do - decorated <- decorateDiagnostic logflags (messageClass doc) location - if log_diags_as_json then do - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message - - logJsonMsg logger (messageClass decorated) jsonMessage - else do - logMsg logger (messageClass decorated) + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message = do doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: SDoc -> Message - messageClass = UnsafeMCDiagnostic location severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message = do severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,21 +93,18 @@ printMessage logger msg_opts opts message = do hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) - -decorateDiagnostic :: LogFlags -> Message -> SrcSpan -> IO SDoc -decorateDiagnostic logflags msg srcSpan = addCaret +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret where -- Pretty print the warning flag, if any (#10752) message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg srcSpan + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc addCaret :: IO SDoc addCaret = do caretDiagnostic <- if log_show_caret logflags - then getCaretDiagnostic msg srcSpan + then getCaretDiagnostic severity span else pure empty return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1445,9 +1445,9 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msg = do let action = logMsg logger msg case msg of - MCDiagnostic _ SevWarning _reason _code _ + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic _ SevError _reason _code _ + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -122,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook -pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () -pushJsonLogHookM = modifyLogger . pushJsonLogHook - -popJsonLogHookM :: GhcMonad m => m () -popJsonLogHookM = modifyLogger popJsonLogHook - -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -70,7 +70,6 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessageWarningGroups , formatLocMessage , formatFatalLocMessage , formatDiagnostic @@ -493,7 +492,7 @@ data Message -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -509,8 +508,8 @@ data Message -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> Message -pattern MCDiagnostic span severity reason code doc <- UnsafeMCDiagnostic span severity reason code doc +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -635,25 +634,9 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> Message -- ^ message - -> SrcSpan -- ^ location - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg locn - = case msg of - MCDiagnostic span severity reason code doc -> formatDiagnostic show_warn_groups span severity reason code doc - MCFatal doc -> formatFatalLocMessage locn doc - MCOutput doc -> formatLocMessage locn doc - MCInteractive doc -> formatLocMessage locn doc - MCDump doc -> formatLocMessage locn doc - MCInfo doc -> formatLocMessage locn doc - formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> - let msg_title = coloured (fatalColour col_scheme) $ text "fatal" + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg formatLocMessage :: SrcSpan -> SDoc -> SDoc @@ -770,23 +753,15 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg in coloured (Col.sMessage col_scheme) $ hang (coloured (Col.sHeader col_scheme) header) 4 msg -getMessageClassColour :: Message -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic _span severity _reason _code _) = getSeverityColour severity -getMessageClassColour (MCFatal _) = fatalColour -getMessageClassColour _ = const mempty - -fatalColour :: Col.Scheme -> Col.PprColour -fatalColour = Col.sFatal - getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of SevError -> Col.sError SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: Message -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -819,7 +794,7 @@ getCaretDiagnostic msg (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,11 +52,9 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg -- * Dumping @@ -86,8 +81,8 @@ import GHC.Types.Error import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet @@ -181,11 +176,6 @@ type LogAction = LogFlags -> Message -> IO () -type LogJsonAction = LogFlags - -> Message - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -223,9 +213,6 @@ data Logger = Logger { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack - , json_log_hook :: [LogJsonAction -> LogJsonAction] - -- ^ Json log hooks stack - , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -261,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -273,10 +259,6 @@ initLogger = do putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) --- | Log a JsonDoc -putJsonLogMsg :: Logger -> LogJsonAction -putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) - -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -301,15 +283,6 @@ popLogHook logger = case log_hook logger of [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } --- | Push a json log hook -pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger -pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } - -popJsonLogHook :: Logger -> Logger -popJsonLogHook logger = case json_log_hook logger of - [] -> panic "popJsonLogHook: empty hook stack" - _:hs -> logger { json_log_hook = hs} - -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -353,22 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger -defaultLogJsonAction :: LogJsonAction -defaultLogJsonAction logflags msg_class jsdoc = - case msg_class of - MCOutput _ -> printOut msg - MCDump _ -> printOut (msg $$ blankLine) - MCInteractive _ -> putStrSDoc msg - MCInfo _ -> printErrs msg - MCFatal _ -> printErrs msg - MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message - MCDiagnostic _span _sev _rea _code _ -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -386,8 +343,12 @@ defaultLogActionWithHandles out err logflags message MCInteractive msg -> putStrSDoc msg MCInfo msg -> printErrs msg MCFatal msg -> printErrs msg - MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message - MCDiagnostic _span _sev _rea _code msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err @@ -534,9 +495,6 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> Message -> IO () logMsg logger = putLogMsg logger (logFlags logger) -logJsonMsg :: Logger -> Message -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc - -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () logDumpFile logger = putDumpFile logger (logFlags logger) ===================================== ghc/GHCi/UI.hs ===================================== @@ -836,7 +836,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg = do old_log_action dflags msg case msg of - MCDiagnostic srcSpan SevError _reason _code _ -> case srcSpan of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] 20 commits: README: Add note on ghc.nix
by Simon Hengel (＠sol) 10 Aug '25

10 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00 README: Add note on ghc.nix - - - - - 93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00 Link to the "Strict Bindings" docs from the linear types docs Strict Bidings are relevant for the kinds of multiplicity annotations linear lets support. - - - - - 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00 ipe: Place strings and metadata into specific .ipe section By placing the .ipe metadata into a specific section it can be stripped from the final binary if desired. ``` objcopy --remove-section .ipe <binary> upx <binary> ``` Towards #21766 - - - - - c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Place magic word at the start of entries in the .ipe section The magic word "IPE\nIPE\n" is placed at the start of .ipe sections, then if the section is stripped, we can check whether the section starts with the magic word or not to determine whether there is metadata present or not. Towards #21766 - - - - - cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Use stable IDs for IPE entries IPEs have historically been indexed and reported by their address. This makes it impossible to compare profiles between runs, since the addresses may change (due to ASLR) and also makes it tricky to separate out the IPE map from the binary. This small patch adds a stable identifier for each IPE entry. The stable identifier is a single 64 bit word. The high-bits are a per-module identifier and the low bits identify which entry in each module. 1. When a node is added into the IPE buffer it is assigned a unique identifier from an incrementing global counter. 2. Each entry already has an index by it's position in the `IpeBufferListNode`. The two are combined together by the `IPE_ENTRY_KEY` macro. Info table profiling uses the stable identifier rather than the address of the info table. The benefits of this change are: * Profiles from different runs can be easily compared * The metadata can be extracted from the binary (via the eventlog for example) and then stripped from the executable. Fixes #21766 - - - - - 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00 In TcSShortCut, typechecker plugins should get empty Givens Solving in TcShortCut mode means /ignoring the Givens/. So we should not pass them to typechecker plugins! Fixes #26258. This is a fixup to the earlier MR: commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jul 21 10:04:49 2025 +0100 Improve treatment of SPECIALISE pragmas -- again! - - - - - 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00 Add default QuasiQuoters Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier to write `QuasiQuoters` that give helpful error messages when they're used in inappropriate contexts. Closes #24434. - - - - - 397763da by Simon Hengel at 2025-08-10T06:12:02+07:00 Refactoring: Don't misuse `MCDiagnostic` for lint messages `MCDiagnostic` is meant to be used for compiler diagnostics. Any code that creates `MCDiagnostic` directly, without going through `GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json` (see e.g. !14475, !14492 !14548). To avoid this in the future I want to control more narrowly who creates `MCDiagnostic` (see #24113). Some parts of the compiler use `MCDiagnostic` purely for formatting purposes, without creating any real compiler diagnostics. This change introduces a helper function, `formatDiagnostic`, that can be used in such cases instead of constructing `MCDiagnostic`. - - - - - c6392ebb by Simon Hengel at 2025-08-10T06:12:02+07:00 Rename MCDiagnostic to UnsafeMCDiagnostic - - - - - 1fee223a by Simon Hengel at 2025-08-10T06:12:02+07:00 Remove -ddump-json (fixes #24113) - - - - - 8873732c by Simon Hengel at 2025-08-10T06:12:02+07:00 Add SrcSpan to MCDiagnostic - - - - - f60aac7a by Simon Hengel at 2025-08-10T06:12:02+07:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - c6b49448 by Simon Hengel at 2025-08-10T06:12:02+07:00 Get rid of mkLocMessage - - - - - 34d6baea by Simon Hengel at 2025-08-10T06:12:02+07:00 Add Message data type - - - - - 1f5a353e by Simon Hengel at 2025-08-10T06:12:02+07:00 Get rid of MessageClass - - - - - 4c776200 by Simon Hengel at 2025-08-10T06:12:02+07:00 Rename DiagnosticMessage to GenericDiagnosticMessage - - - - - b6f47d1e by Simon Hengel at 2025-08-10T09:34:48+07:00 Remove JSON logging - - - - - 78 changed files: - .gitlab/darwin/toolchain.nix - README.md - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SourceError.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debug-info.rst - docs/users_guide/debugging.rst - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/strict.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - rts/IPE.c - rts/ProfHeap.c - rts/eventlog/EventLog.c - rts/include/rts/IPE.h - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T - utils/check-exact/Main.hs - utils/check-exact/Preprocess.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] Start to extend to equalities
by Simon Peyton Jones (＠simonpj) 10 Aug '25

10 Aug '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 02401833 by Simon Peyton Jones at 2025-08-10T00:14:42+01:00 Start to extend to equalities - - - - - 4 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/Monad.hs Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin import GHC.Tc.Types.EvTerm( evCallStack ) -import GHC.Tc.Solver.FunDeps( doDictFunDepImprovement ) +import GHC.Tc.Solver.FunDeps( tryDictFunDeps ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Solver.Types @@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) -- Try fundeps /after/ tryInstances: -- see (DFL2) in Note [Do fundeps last] - ; doDictFunDepImprovement dict_ct + ; tryDictFunDeps dict_ct ; simpleStage (updInertDicts dict_ct) ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -16,9 +16,8 @@ import GHC.Tc.Solver.Irred( solveIrred ) import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad -import GHC.Tc.Solver.FunDeps( unifyAndEmitFunDepWanteds ) +import GHC.Tc.Solver.FunDeps( tryEqFunDeps ) import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Types( findFunEqsByTyCon ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc @@ -26,7 +25,6 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) import qualified GHC.Tc.Utils.Monad as TcM import GHC.Core.Type @@ -36,21 +34,15 @@ import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom import GHC.Core.Reduction -import GHC.Core.Unify( tcUnifyTyForInjectivity ) -import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck - , lookupFamInstEnvByTyCon ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core - import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set( anyVarSet ) import GHC.Types.Name.Reader import GHC.Types.Basic -import GHC.Builtin.Types.Literals ( tryInteractTopFam, tryInteractInertFam ) - import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc @@ -120,9 +112,9 @@ solveEquality ev eq_rel ty1 ty2 Left irred_ct -> do { tryQCsIrredEqCt irred_ct ; solveIrred irred_ct } ; - Right eq_ct -> do { tryInertEqs eq_ct - ; tryFunDeps eq_ct - ; tryQCsEqCt eq_ct + Right eq_ct -> do { tryInertEqs eq_ct + ; tryEqFunDeps eq_ct + ; tryQCsEqCt eq_ct ; simpleStage (updInertEqs eq_ct) ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } @@ -2025,7 +2017,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs evCoercion (mkNomReflCo final_rhs) -- Kick out any constraints that can now be rewritten - ; kickOutAfterUnification [tv] + ; recordUnification tv ; return (Stop new_ev (text "Solved by unification")) } @@ -2996,456 +2988,3 @@ lovely quantified constraint. Alas! This test arranges to ignore the instance-based solution under these (rare) circumstances. It's sad, but I really don't see what else we can do. -} - - -{- -********************************************************************** -* * - Functional dependencies for type families -* * -********************************************************************** - -Note [Reverse order of fundep equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this scenario (from dependent/should_fail/T13135_simple): - - type Sig :: Type -> Type - data Sig a = SigFun a (Sig a) - - type SmartFun :: forall (t :: Type). Sig t -> Type - type family SmartFun sig = r | r -> sig where - SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig - - [W] SmartFun @kappa sigma ~ (Int -> Bool) - -The injectivity of SmartFun allows us to produce two new equalities: - - [W] w1 :: Type ~ kappa - [W] w2 :: SigFun @Type Int beta ~ sigma - -for some fresh (beta :: SigType). The second Wanted here is actually -heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. -Of course, if we solve the first wanted first, the second becomes homogeneous. - -When looking for injectivity-inspired equalities, we work left-to-right, -producing the two equalities in the order written above. However, these -equalities are then passed into wrapUnifierTcS, which will fail, adding these -to the work list. However, crucially, the work list operates like a *stack*. -So, because we add w1 and then w2, we process w2 first. This is silly: solving -w1 would unlock w2. So we make sure to add equalities to the work -list in left-to-right order, which requires a few key calls to 'reverse'. - -This treatment is also used for class-based functional dependencies, although -we do not have a program yet known to exhibit a loop there. It just seems -like the right thing to do. - -When this was originally conceived, it was necessary to avoid a loop in T13135. -That loop is now avoided by continuing with the kind equality (not the type -equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]). -However, the idea of working left-to-right still seems worthwhile, and so the calls -to 'reverse' remain. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation], which describes -the Exact Same Problem, with the same solution, but for functional dependencies. - -A very delicate point is the orientation of equalities -arising from injectivity improvement (#12522). Suppose we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] F (alpha, beta) ~ (Int, <some type>) - -The injectivity will give rise to constraints - - [W] gamma1 ~ alpha - [W] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -favour of alpha. If we instead had - [W] alpha ~ gamma1 -then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we substitute it back in, it'd look like - [W] F (gamma1, beta) ~ fuv -and exactly the same thing would happen again! Infinite loop. - -This all seems fragile, and it might seem more robust to avoid -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new -equality with the template on the left. Delicate, but it works. - --} - --------------------- - -tryFunDeps :: EqCt -> SolverStage () -tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel }) - | NomEq <- eq_rel - , TyFamLHS tc args <- lhs - = Stage $ - do { inerts <- getInertCans - ; imp1 <- improveLocalFunEqs inerts tc args work_item - ; imp2 <- improveTopFunEqs tc args work_item - ; if (imp1 || imp2) - then startAgainWith (mkNonCanonical ev) - else continueWith () } - | otherwise - = nopStage () - --------------------- -improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool --- TyCon is definitely a type family --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty }) - | isGiven ev = improveGivenTopFunEqs fam_tc args ev rhs_ty - | otherwise = improveWantedTopFunEqs fam_tc args ev rhs_ty - -improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool --- TyCon is definitely a type family --- Work-item is a Given -improveGivenTopFunEqs fam_tc args ev rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty) - ; emitNewGivens (ctEvLoc ev) $ - [ (Nominal, new_co) - | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty - , let new_co = mkAxiomCo ax [given_co] ] - ; return False } -- False: no unifications - | otherwise - = return False - where - given_co :: Coercion = ctEvCoercion ev - -improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool --- TyCon is definitely a type family --- Work-item is a Wanted -improveWantedTopFunEqs fam_tc args ev rhs_ty - = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty - ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args - , text "rhs:" <+> ppr rhs_ty - , text "eqns:" <+> ppr eqns ]) - ; unifyFunDeps ev Nominal $ \uenv -> - uPairsTcM (bump_depth uenv) (reverse eqns) } - -- Missing that `reverse` causes T13135 and T13135_simple to loop. - -- See Note [Reverse order of fundep equations] - - where - bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } - -- ToDo: this location is wrong; it should be FunDepOrigin2 - -- See #14778 - -improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi - -> TcS [TypeEqn] --- TyCon is definitely a type family -improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty) - - -- ToDo: use ideas in #23162 for closed type families; injectivity only for open - - -- See Note [Type inference for type families with injectivity] - -- Open, so look for inj - | Injective inj_args <- tyConInjectivityInfo fam_tc - = do { fam_envs <- getFamInstEnvs - ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty - ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty - ; traceTcS "improve_wanted_top_fun_eqs" $ - vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ] - -- xxx ToDo: this does both local and top => bug? - ; return (local_eqns ++ top_eqns) } - - | otherwise -- No injectivity - = return [] - -improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn] --- Interact with top-level instance declarations --- See Section 5.2 in the Injective Type Families paper -improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty - = concatMapM do_one branches - where - branches :: [CoAxBranch] - branches | isOpenTypeFamilyTyCon fam_tc - , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc - = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc - = fromBranches (coAxiomBranches ax) - - | otherwise - = [] - - do_one :: CoAxBranch -> TcS [TypeEqn] - do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs }) - | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs - , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty - -- False: matching, not unifying - = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst - unsubstTvs = filterOut inSubst branch_tvs - -- The order of unsubstTvs is important; it must be - -- in telescope order e.g. (k:*) (a:k) - - ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs - -- If the current substitution bind [k -> *], and - -- one of the un-substituted tyvars is (a::k), we'd better - -- be sure to apply the current substitution to a's kind. - -- Hence instFlexiX. #13135 was an example. - - ; traceTcS "improve_inj_top" $ - vcat [ text "branch_rhs" <+> ppr branch_rhs - , text "rhs_ty" <+> ppr rhs_ty - , text "subst" <+> ppr subst - , text "subst1" <+> ppr subst1 ] - ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch - then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys) - ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) } - -- NB: The fresh unification variables (from unsubstTvs) are on the left - -- See Note [Improvement orientation] - else do { traceTcS "improve_inj_top2" empty; return [] } } - | otherwise - = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs) - ; return [] } - - in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) - - -improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn] --- Interact with itself, specifically F s1 s2 ~ F t1 t2 -improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty - | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty - , tc == fam_tc - = mkInjectivityEqns inj_args lhs_tys rhs_tys - | otherwise - = [] - -mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn] --- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True] --- return the equations [Pair s1 t1, Pair s3 t3] -mkInjectivityEqns inj_args lhs_args rhs_args - = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ] - ---------------------------------------------- -improveLocalFunEqs :: InertCans - -> TyCon -> [TcType] -> EqCt -- F args ~ rhs - -> TcS Bool --- Emit equalities from interaction between two equalities -improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs }) - | isGiven work_ev = improveGivenLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs - | otherwise = improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs - where - funeqs = inert_funeqs inerts - funeqs_for_tc :: [EqCt] -- Mixture of Given and Wanted - funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc - , funeq_ct <- equal_ct_list - , NomEq == eq_eq_rel funeq_ct ] - -- Representational equalities don't interact - -- with type family dependencies - - -improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted - -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given) - -> TcS Bool -- Always False (no unifications) --- Emit equalities from interaction between two Given type-family equalities --- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2) -improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = do { mapM_ (do_one ops) funeqs_for_tc - ; return False } -- False: no unifications - | otherwise - = return False - where - given_co :: Coercion = ctEvCoercion work_ev - - do_one :: BuiltInSynFamily -> EqCt -> TcS () - -- Used only work-item is Given - do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs } - | isGiven inert_ev -- Given/Given interaction - , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs - , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same - , -- So we have work_ev : F work_args ~ rhs - -- inert_ev : F inert_args ~ rhs - let pairs :: [(CoAxiomRule, TypeEqn)] - pairs = tryInteractInertFam ops fam_tc work_args inert_args - , not (null pairs) - = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args - , text "work_ev" <+> ppr work_ev - , text "inert_ev" <+> ppr inert_ev - , ppr work_rhs - , ppr pairs ]) - ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) } - -- This CtLoc for the new Givens doesn't reflect the - -- fact that it's a combination of Givens, but I don't - -- this that matters. - where - inert_co = ctEvCoercion inert_ev - mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co]) - where - combined_co = given_co `mkTransCo` mkSymCo inert_co - -- given_co :: F work_args ~ rhs - -- inert_co :: F inert_args ~ rhs - -- the_co :: F work_args ~ F inert_args - - do_one _ _ = return () - -improveWantedLocalFunEqs - :: [EqCt] -- Inert items (Given and Wanted) - -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted) - -> TcS Bool -- True <=> some unifications --- Emit improvement equalities for a Wanted constraint, by comparing --- the current work item with inert CFunEqs (both Given and Wanted) --- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs - | null improvement_eqns - = return False - | otherwise - = do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr improvement_eqns - , text "Candidates:" <+> ppr funeqs_for_tc ] - ; unifyAndEmitFunDepWanteds work_ev improvement_eqns } - where - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = tyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - concatMap (do_one_built_in ops rhs) funeqs_for_tc - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - concatMap (do_one_injective injective_args rhs) funeqs_for_tc - - | otherwise - = [] - - -------------------- - do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev }) - | irhs `tcEqType` rhs - = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs) - | otherwise - = [] - do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args - , eq_rhs = irhs, eq_ev = inert_ev }) - | rhs `tcEqType` irhs - = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args - | otherwise - = [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_loc = (loc, inert_rewriters) } ] - where - initial_loc -- start with the location of the Wanted involved - | isGiven work_ev = inert_loc - | otherwise = work_loc - eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) - inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) - eqn_loc = setCtLocOrigin initial_loc eqn_orig - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctEvRewriters inert_ev - loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have an equality like F s1 t1 ~ F s2 t2, -we can use the injectivity to get a new Wanted constraint on -the injective argument - [W] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and inferring values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are Wanted constraints, but we will not use the evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -We generate these Wanteds in three places, depending on how we notice the -injectivity. - -1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and -described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality - -2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these -constraints rewrites the other, as they have different LHSs. This is done -in improveLocalFunEqs, called during the interactWithInertsStage. - -3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. -This is done in improve_top_fun_eqs, called from the top-level reactions stage. - -See also Note [Injective type families] in GHC.Core.TyCon - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - (i) Will set g2 := g1 `cast` g3 - (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - (iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. --} ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -4,7 +4,8 @@ -- | Solving Class constraints CDictCan module GHC.Tc.Solver.FunDeps ( unifyAndEmitFunDepWanteds, - doDictFunDepImprovement, + tryDictFunDeps, + tryEqFunDeps ) where import GHC.Prelude @@ -12,25 +13,34 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds ) import GHC.Tc.Instance.FunDeps -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Solver.Types import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify( UnifyEnv(..) ) import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin import GHC.Core.Type -import GHC.Core.InstEnv ( ClsInst(..) ) -import GHC.Core.Coercion.Axiom( TypeEqn ) - +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Core.Predicate( EqRel(..) ) +import GHC.Core.TyCon +import GHC.Core.Unify( tcUnifyTyForInjectivity ) +import GHC.Core.InstEnv( ClsInst(..) ) +import GHC.Core.Coercion.Axiom + +import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam ) import GHC.Types.Name import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc( filterOut ) import GHC.Data.Bag import GHC.Data.Pair @@ -41,7 +51,7 @@ import Control.Monad {- ********************************************************************* * * -* Functional dependencies, instantiation of equations +* Functional dependencies for dictionaries * * ************************************************************************ @@ -296,24 +306,24 @@ as the fundeps. #7875 is a case in point. -} -doDictFunDepImprovement :: DictCt -> SolverStage () --- (doDictFunDepImprovement inst_envs cts) +tryDictFunDeps :: DictCt -> SolverStage () +-- (tryDictFunDeps inst_envs cts) -- * Generate the fundeps from interacting the -- top-level `inst_envs` with the constraints `cts` -- * Do the unifications and return any unsolved constraints -- See Note [Fundeps with instances, and equality orientation] --- doLocalFunDepImprovement does StartAgain if there +-- doLocalFunDeps does StartAgain if there -- are any fundeps: see (DFL1) in Note [Do fundeps last] -doDictFunDepImprovement dict_ct - = do { doDictFunDepImprovementLocal dict_ct - ; doDictFunDepImprovementTop dict_ct } +tryDictFunDeps dict_ct + = do { tryDictFunDepsLocal dict_ct + ; tryDictFunDepsTop dict_ct } -doDictFunDepImprovementLocal :: DictCt -> SolverStage () +tryDictFunDepsLocal :: DictCt -> SolverStage () -- Using functional dependencies, interact the DictCt with the -- inert Givens and Wanteds, to produce new equalities -doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) +tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) | isGiven work_ev = -- If work_ev is Given, there could in principle be some inert Wanteds -- but in practice there never are because we solve Givens first @@ -323,11 +333,11 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) = Stage $ do { inerts <- getInertCans - ; traceTcS "doDictFunDepImprovementLocal {" (ppr dict_ct) + ; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct) ; imp <- solveFunDeps $ foldM do_interaction emptyCts $ findDictsByClass (inert_dicts inerts) cls - ; traceTcS "doDictFunDepImprovementLocal }" (text "imp =" <+> ppr imp) + ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp) ; if imp then startAgainWith (CDictCan dict_ct) else continueWith () } @@ -350,7 +360,7 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) improveFromAnother (deriv_loc, inert_rewriters) inert_pred work_pred - ; traceTcS "doDictFunDepImprovementLocal item" $ + ; traceTcS "tryDictFunDepsLocal item" $ vcat [ ppr work_ev, ppr new_eqs2 ] ; return (new_eqs1 `unionBags` new_eqs2) } @@ -369,17 +379,17 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) (ctLocOrigin inert_loc) (ctLocSpan inert_loc) -doDictFunDepImprovementTop :: DictCt -> SolverStage () -doDictFunDepImprovementTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) +tryDictFunDepsTop :: DictCt -> SolverStage () +tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) = Stage $ do { inst_envs <- getInstEnvs - ; traceTcS "doDictFunDepImprovementTop {" (ppr dict_ct) + ; traceTcS "tryDictFunDepsTop {" (ppr dict_ct) ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)] eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis ; imp <- solveFunDeps $ unifyFunDepWanteds_new ev eqns - ; traceTcS "doDictFunDepImprovementTop }" (text "imp =" <+> ppr imp) + ; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp) ; if imp then startAgainWith (CDictCan dict_ct) else continueWith () } @@ -469,6 +479,464 @@ The bottom line: since we have no evidence for them, we should ignore Given/Give and Given/instance fundeps entirely. -} + + +{- +********************************************************************** +* * + Functional dependencies for type families +* * +********************************************************************** + +Note [Reverse order of fundep equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this scenario (from dependent/should_fail/T13135_simple): + + type Sig :: Type -> Type + data Sig a = SigFun a (Sig a) + + type SmartFun :: forall (t :: Type). Sig t -> Type + type family SmartFun sig = r | r -> sig where + SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig + + [W] SmartFun @kappa sigma ~ (Int -> Bool) + +The injectivity of SmartFun allows us to produce two new equalities: + + [W] w1 :: Type ~ kappa + [W] w2 :: SigFun @Type Int beta ~ sigma + +for some fresh (beta :: SigType). The second Wanted here is actually +heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. +Of course, if we solve the first wanted first, the second becomes homogeneous. + +When looking for injectivity-inspired equalities, we work left-to-right, +producing the two equalities in the order written above. However, these +equalities are then passed into wrapUnifierTcS, which will fail, adding these +to the work list. However, crucially, the work list operates like a *stack*. +So, because we add w1 and then w2, we process w2 first. This is silly: solving +w1 would unlock w2. So we make sure to add equalities to the work +list in left-to-right order, which requires a few key calls to 'reverse'. + +This treatment is also used for class-based functional dependencies, although +we do not have a program yet known to exhibit a loop there. It just seems +like the right thing to do. + +When this was originally conceived, it was necessary to avoid a loop in T13135. +That loop is now avoided by continuing with the kind equality (not the type +equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]). +However, the idea of working left-to-right still seems worthwhile, and so the calls +to 'reverse' remain. + +Note [Improvement orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation], which describes +the Exact Same Problem, with the same solution, but for functional dependencies. + +A very delicate point is the orientation of equalities +arising from injectivity improvement (#12522). Suppose we have + type family F x = t | t -> x + type instance F (a, Int) = (Int, G a) +where G is injective; and wanted constraints + + [W] F (alpha, beta) ~ (Int, <some type>) + +The injectivity will give rise to constraints + + [W] gamma1 ~ alpha + [W] Int ~ beta + +The fresh unification variable gamma1 comes from the fact that we +can only do "partial improvement" here; see Section 5.2 of +"Injective type families for Haskell" (HS'15). + +Now, it's very important to orient the equations this way round, +so that the fresh unification variable will be eliminated in +favour of alpha. If we instead had + [W] alpha ~ gamma1 +then we would unify alpha := gamma1; and kick out the wanted +constraint. But when we substitute it back in, it'd look like + [W] F (gamma1, beta) ~ fuv +and exactly the same thing would happen again! Infinite loop. + +---> ToDo: all this fragility has gone away! Fix the Note! <--- + +This all seems fragile, and it might seem more robust to avoid +introducing gamma1 in the first place, in the case where the +actual argument (alpha, beta) partly matches the improvement +template. But that's a bit tricky, esp when we remember that the +kinds much match too; so it's easier to let the normal machinery +handle it. Instead we are careful to orient the new +equality with the template on the left. Delicate, but it works. + +-} + +-------------------- +tryEqFunDeps :: EqCt -> SolverStage () +tryEqFunDeps work_item@(EqCt { eq_lhs = lhs, eq_eq_rel = eq_rel }) + | NomEq <- eq_rel + , TyFamLHS tc args <- lhs + = do { improveLocalFunEqs tc args work_item + ; improveTopFunEqs tc args work_item } + | otherwise + = nopStage () + +-------------------- +improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> SolverStage () +-- TyCon is definitely a type family +-- See Note [FunDep and implicit parameter reactions] +improveTopFunEqs fam_tc args eq_ct@(EqCt { eq_ev = ev, eq_rhs = rhs_ty }) + = Stage $ + do { imp <- if isGiven ev + then improveGivenTopFunEqs fam_tc args ev rhs_ty + else improveWantedTopFunEqs fam_tc args ev rhs_ty + ; if imp then startAgainWith (CEqCan eq_ct) + else continueWith () } + +improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool +-- TyCon is definitely a type family +-- Work-item is a Given +improveGivenTopFunEqs fam_tc args ev rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty) + ; emitNewGivens (ctEvLoc ev) $ + [ (Nominal, new_co) + | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty + , let new_co = mkAxiomCo ax [given_co] ] + ; return False } -- False: no unifications + | otherwise + = return False + where + given_co :: Coercion = ctEvCoercion ev + +improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool +-- TyCon is definitely a type family +-- Work-item is a Wanted +improveWantedTopFunEqs fam_tc args ev rhs_ty + = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty + ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args + , text "rhs:" <+> ppr rhs_ty + , text "eqns:" <+> ppr eqns ]) + ; unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM (bump_depth uenv) (reverse eqns) } + -- Missing that `reverse` causes T13135 and T13135_simple to loop. + -- See Note [Reverse order of fundep equations] + + where + bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } + -- ToDo: this location is wrong; it should be FunDepOrigin2 + -- See #14778 + +improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi + -> TcS [TypeEqn] +-- TyCon is definitely a type family +improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty) + + -- ToDo: use ideas in #23162 for closed type families; injectivity only for open + + -- See Note [Type inference for type families with injectivity] + -- Open, so look for inj + | Injective inj_args <- tyConInjectivityInfo fam_tc + = do { fam_envs <- getFamInstEnvs + ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty + ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty + ; traceTcS "improve_wanted_top_fun_eqs" $ + vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ] + -- xxx ToDo: this does both local and top => bug? + ; return (local_eqns ++ top_eqns) } + + | otherwise -- No injectivity + = return [] + +improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn] +-- Interact with top-level instance declarations +-- See Section 5.2 in the Injective Type Families paper +improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty + = concatMapM do_one branches + where + branches :: [CoAxBranch] + branches | isOpenTypeFamilyTyCon fam_tc + , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc + = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc + = fromBranches (coAxiomBranches ax) + + | otherwise + = [] + + do_one :: CoAxBranch -> TcS [TypeEqn] + do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs }) + | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs + , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty + -- False: matching, not unifying + = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst + unsubstTvs = filterOut inSubst branch_tvs + -- The order of unsubstTvs is important; it must be + -- in telescope order e.g. (k:*) (a:k) + + ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs + -- If the current substitution bind [k -> *], and + -- one of the un-substituted tyvars is (a::k), we'd better + -- be sure to apply the current substitution to a's kind. + -- Hence instFlexiX. #13135 was an example. + + ; traceTcS "improve_inj_top" $ + vcat [ text "branch_rhs" <+> ppr branch_rhs + , text "rhs_ty" <+> ppr rhs_ty + , text "subst" <+> ppr subst + , text "subst1" <+> ppr subst1 ] + ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch + then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys) + ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) } + -- NB: The fresh unification variables (from unsubstTvs) are on the left + -- See Note [Improvement orientation] + else do { traceTcS "improve_inj_top2" empty; return [] } } + | otherwise + = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs) + ; return [] } + + in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) + + +improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn] +-- Interact with itself, specifically F s1 s2 ~ F t1 t2 +improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty + | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty + , tc == fam_tc + = mkInjectivityEqns inj_args lhs_tys rhs_tys + | otherwise + = [] + +mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn] +-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True] +-- return the equations [Pair s1 t1, Pair s3 t3] +mkInjectivityEqns inj_args lhs_args rhs_args + = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ] + +--------------------------------------------- +improveLocalFunEqs :: TyCon -> [TcType] -> EqCt -- F args ~ rhs + -> SolverStage () +-- Emit equalities from interaction between two equalities +improveLocalFunEqs fam_tc args eq_ct@(EqCt { eq_ev = work_ev, eq_rhs = rhs }) + = Stage $ + do { inerts <- getInertCans + ; let my_funeqs = get_my_funeqs inerts + ; imp <- if isGiven work_ev + then improveGivenLocalFunEqs my_funeqs fam_tc args work_ev rhs + else improveWantedLocalFunEqs my_funeqs fam_tc args work_ev rhs + ; if imp then startAgainWith (CEqCan eq_ct) + else continueWith () } + where + get_my_funeqs :: InertCans -> [EqCt] -- Mixture of Given and Wanted + get_my_funeqs (IC { inert_funeqs = funeqs }) + = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc + , funeq_ct <- equal_ct_list + , NomEq == eq_eq_rel funeq_ct ] + -- Representational equalities don't interact + -- with type family dependencies + +improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted + -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given) + -> TcS Bool -- Always False (no unifications) +-- Emit equalities from interaction between two Given type-family equalities +-- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2) +improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { mapM_ (do_one ops) funeqs_for_tc + ; return False } -- False: no unifications + | otherwise + = return False + where + given_co :: Coercion = ctEvCoercion work_ev + + do_one :: BuiltInSynFamily -> EqCt -> TcS () + -- Used only work-item is Given + do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs } + | isGiven inert_ev -- Given/Given interaction + , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs + , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same + , -- So we have work_ev : F work_args ~ rhs + -- inert_ev : F inert_args ~ rhs + let pairs :: [(CoAxiomRule, TypeEqn)] + pairs = tryInteractInertFam ops fam_tc work_args inert_args + , not (null pairs) + = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args + , text "work_ev" <+> ppr work_ev + , text "inert_ev" <+> ppr inert_ev + , ppr work_rhs + , ppr pairs ]) + ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) } + -- This CtLoc for the new Givens doesn't reflect the + -- fact that it's a combination of Givens, but I don't + -- this that matters. + where + inert_co = ctEvCoercion inert_ev + mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co]) + where + combined_co = given_co `mkTransCo` mkSymCo inert_co + -- given_co :: F work_args ~ rhs + -- inert_co :: F inert_args ~ rhs + -- the_co :: F work_args ~ F inert_args + + do_one _ _ = return () + +improveWantedLocalFunEqs + :: [EqCt] -- Inert items (Given and Wanted) + -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted) + -> TcS Bool -- True <=> some unifications +-- Emit improvement equalities for a Wanted constraint, by comparing +-- the current work item with inert CFunEqs (both Given and Wanted) +-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' +-- +-- See Note [FunDep and implicit parameter reactions] +improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs + | null improvement_eqns + = return False + | otherwise + = do { traceTcS "interactFunEq improvements: " $ + vcat [ text "Eqns:" <+> ppr improvement_eqns + , text "Candidates:" <+> ppr funeqs_for_tc ] + ; unifyAndEmitFunDepWanteds work_ev improvement_eqns } + where + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + concatMap (do_one_built_in ops rhs) funeqs_for_tc + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + concatMap (do_one_injective injective_args rhs) funeqs_for_tc + + | otherwise + = [] + + -------------------- + do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev }) + | irhs `tcEqType` rhs + = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs) + | otherwise + = [] + do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS + + -------------------- + -- See Note [Type inference for type families with injectivity] + do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args + , eq_rhs = irhs, eq_ev = inert_ev }) + | rhs `tcEqType` irhs + = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args + | otherwise + = [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , fd_loc = (loc, inert_rewriters) } ] + where + initial_loc -- start with the location of the Wanted involved + | isGiven work_ev = inert_loc + | otherwise = work_loc + eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) + inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) + eqn_loc = setCtLocOrigin initial_loc eqn_orig + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +{- Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have an equality like F s1 t1 ~ F s2 t2, +we can use the injectivity to get a new Wanted constraint on +the injective argument + [W] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and inferring values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are Wanted constraints, but we will not use the evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +We generate these Wanteds in three places, depending on how we notice the +injectivity. + +1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and +described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality + +2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these +constraints rewrites the other, as they have different LHSs. This is done +in improveLocalFunEqs, called during the interactWithInertsStage. + +3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. +This is done in improve_top_fun_eqs, called from the top-level reactions stage. + +See also Note [Injective type families] in GHC.Core.TyCon + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + (i) Will set g2 := g1 `cast` g3 + (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + (iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. +-} + {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -67,9 +67,6 @@ module GHC.Tc.Solver.Monad ( getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, tcLookupClass, tcLookupId, tcLookupTyCon, - getUnifiedRef, - - -- Inerts updInertSet, updInertCans, getHasGivenEqs, setInertCans, @@ -84,7 +81,7 @@ module GHC.Tc.Solver.Monad ( lookupInertDict, -- The Model - kickOutAfterUnification, kickOutRewritable, + recordUnification, recordUnifications, kickOutRewritable, -- Inert Safe Haskell safe-overlap failures insertSafeOverlapFailureTcS, @@ -212,8 +209,6 @@ import Control.Monad import Data.Foldable hiding ( foldr1 ) import Data.IORef import Data.List ( mapAccumL ) -import Data.List.NonEmpty ( nonEmpty ) -import qualified Data.List.NonEmpty as NE import GHC.Types.SrcLoc import GHC.Rename.Env import GHC.LanguageExtensions as LangExt @@ -450,33 +445,6 @@ kickOutRewritable ko_spec new_fr , text "kicked_out =" <+> ppr kicked_out , text "Residual inerts =" <+> ppr ics' ]) } } -kickOutAfterUnification :: [TcTyVar] -> TcS () -kickOutAfterUnification tv_list - = case nonEmpty tv_list of - Nothing -> return () - Just tvs -> do { traceTcS "kickOutAfterUnification" (ppr min_tv_lvl $$ ppr tv_list) - ; setUnificationFlagTo min_tv_lvl } - where - min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs) - -{- - { let tv_set = mkVarSet tv_list - - ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq) - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - -- Set the unification flag if we have done outer unifications - -- that might affect an earlier implication constraint - ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs) - ; ambient_lvl <- getTcLevel - ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $ - setUnificationFlagTo min_tv_lvl - - ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked) - ; return n_kicked } --} - kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () -- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty] -- in GHC.Tc.Solver.Equality @@ -940,11 +908,6 @@ data TcSEnv = TcSEnv { tcs_ev_binds :: EvBindsVar, - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero, so it - -- could equally well be a Bool instead of an Int. - tcs_unif_lvl :: IORef (Maybe TcLevel), -- The Unification Level Flag -- Outermost level at which we have unified a meta tyvar @@ -1131,8 +1094,7 @@ runTcSWithEvBinds' :: TcSMode -> TcS a -> TcM a runTcSWithEvBinds' mode ev_binds_var thing_inside - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 + = do { step_count <- TcM.newTcRef 0 -- Make a fresh, empty inert set -- Subtle point: see (TGE6) in Note [Tracking Given equalities] @@ -1143,7 +1105,6 @@ runTcSWithEvBinds' mode ev_binds_var thing_inside ; wl_var <- TcM.newTcRef emptyWorkList ; unif_lvl_var <- TcM.newTcRef Nothing ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var , tcs_unif_lvl = unif_lvl_var , tcs_count = step_count , tcs_inerts = inert_var @@ -1354,9 +1315,6 @@ setTcSMode :: TcSMode -> TcS a -> TcS a setTcSMode mode thing_inside = TcS (\env -> unTcS thing_inside (env { tcs_mode = mode })) -getUnifiedRef :: TcS (IORef Int) -getUnifiedRef = TcS (return . tcs_unified) - -- Getter of inerts and worklist getInertSetRef :: TcS (IORef InertSet) getInertSetRef = TcS (return . tcs_inerts) @@ -1817,13 +1775,11 @@ produced the same Derived constraint.) unifyTyVar :: TcTyVar -> TcType -> TcS () -- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- -- We should never unify the same variable twice! unifyTyVar tv ty = assertPpr (isMetaTyVar tv) (ppr tv) $ do { liftZonkTcS (TcM.writeMetaTyVar tv ty) -- Produces a trace message - ; setUnificationFlagTo (tcTyVarLevel tv) } + ; recordUnification tv } reportUnifications :: TcS a -> TcS (Bool, a) -- Record whether any unifications are done by thing_inside @@ -1887,6 +1843,18 @@ getUnificationFlag -> do { TcM.writeTcRef ref Nothing ; return True } } +recordUnification :: TcTyVar -> TcS () +recordUnification tv = setUnificationFlagTo (tcTyVarLevel tv) + +recordUnifications :: [TcTyVar] -> TcS () +recordUnifications tvs + = case tvs of + [] -> return () + (tv:tvs) -> do { traceTcS "recordUnifications" (ppr min_tv_lvl $$ ppr tvs) + ; setUnificationFlagTo min_tv_lvl } + where + min_tv_lvl = foldr (minTcLevel . tcTyVarLevel) (tcTyVarLevel tv) tvs + setUnificationFlagTo :: TcLevel -> TcS () -- (setUnificationFlag i) sets the unification level to (Just i) -- unless it already is (Just j) where j <= i @@ -2251,8 +2219,8 @@ unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a) unifyForAllBody ev role unify_body = do { (res, cts, unified) <- wrapUnifierX ev role unify_body - -- Kick out any inert constraint that we have unified - ; kickOutAfterUnification unified + -- Record the unificaions we have done + ; recordUnifications unified ; return (res, cts) } @@ -2271,6 +2239,9 @@ wrapUnifierTcS :: CtEvidence -> Role wrapUnifierTcS ev role do_unifications = do { (res, cts, unified) <- wrapUnifierX ev role do_unifications + -- Record the unificaions we have done + ; recordUnifications unified + -- Emit the deferred constraints -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality -- @@ -2280,17 +2251,13 @@ wrapUnifierTcS ev role do_unifications ; unless (isEmptyBag cts) $ updWorkListTcS (extendWorkListChildEqs ev cts) - -- And kick out any inert constraint that we have unified - ; kickOutAfterUnification unified - ; return (res, cts, unified) } wrapUnifierX :: CtEvidence -> Role -> (UnifyEnv -> TcM a) -- Some calls to uType -> TcS (a, Bag Ct, [TcTyVar]) wrapUnifierX ev role do_unifications - = do { unif_count_ref <- getUnifiedRef - ; given_eq_lvl <- getInnermostGivenEqLevel + = do { given_eq_lvl <- getInnermostGivenEqLevel ; wrapTcS $ do { defer_ref <- TcM.newTcRef emptyBag ; unified_ref <- TcM.newTcRef [] @@ -2308,12 +2275,6 @@ wrapUnifierX ev role do_unifications ; cts <- TcM.readTcRef defer_ref ; unified <- TcM.readTcRef unified_ref - - -- Don't forget to update the count of variables - -- unified, lest we forget to iterate (#24146) - ; unless (null unified) $ - TcM.updTcRef unif_count_ref (+ (length unified)) - ; return (res, cts, unified) } } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/warning-for-last-and-init] 3 commits: Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 09 Aug '25

09 Aug '25

Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: c5ec5732 by Mike Pilgrem at 2025-08-09T00:48:51+01:00 Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`). In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository). Also bumps submodules. - - - - - 31ddd232 by Andrew Lelechenko at 2025-08-09T00:48:51+01:00 Wibble - - - - - d108f076 by Andrew Lelechenko at 2025-08-09T11:07:28+01:00 Wobble - - - - - 26 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Prelude/Basic.hs - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/src/Settings/Warnings.hs - libraries/Cabal - libraries/filepath - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/rts/KeepCafsBase.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/hpc - utils/hsc2hs Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -112,8 +112,7 @@ import GHC.Utils.Misc import Data.ByteString ( ByteString ) import Data.Function ( on ) -import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) -import qualified Data.List as Partial ( init, last ) +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc ) import Data.Ord ( comparing ) import Control.Monad ( guard ) import qualified Data.Set as Set @@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args PrimOpId op _ | primOpIsDiv op - , Lit divisor <- Partial.last args + , Just (initArgs, Lit divisor) <- unsnoc args -- there can be 2 args (most div primops) or 3 args -- (WordQuotRem2Op), hence the use of last/init - -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + module GHC.Driver.Session.Units (initMake, initMulti) where -- The official GHC API ===================================== compiler/GHC/Prelude/Basic.hs ===================================== @@ -2,8 +2,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] --- See Note [Proxies for head and tail] -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} +-- See Note [Proxies for partial list functions] +{-# OPTIONS_GHC -Wno-x-partial #-} -- | Custom minimal GHC "Prelude" -- @@ -24,7 +24,7 @@ module GHC.Prelude.Basic , bit , shiftL, shiftR , setBit, clearBit - , head, tail, unzip + , head, tail, init, last, unzip , strictGenericLength ) where @@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this: -} import qualified Prelude -import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip) import Control.Applicative (Applicative(..)) import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) import Data.Foldable1 as X hiding (head, last) @@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i clearBit :: (Num a, Bits.Bits a) => a -> Int -> a clearBit = \ x i -> x Bits..&. Bits.complement (bit i) -{- Note [Proxies for head and tail] +{- Note [Proxies for partial list functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, +Prelude.head, Prelude.tail, Prelude.init and Prelude.last +have recently acquired {-# WARNING in "x-partial" #-}, but the GHC codebase uses them fairly extensively and insists on building warning-free. Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which employs them, we define warning-less proxies and export them from GHC.Prelude. -} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] head :: HasCallStack => [a] -> a head = Prelude.head {-# INLINE head #-} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-} +-- See Note [Proxies for partial list functions] +init :: HasCallStack => [a] -> [a] +init = Prelude.init +{-# INLINE init #-} + +-- See Note [Proxies for partial list functions] +last :: HasCallStack => [a] -> a +last = Prelude.last +{-# INLINE last #-} + {- | The 'genericLength' function defined in base can't be specialised due to the NOINLINE pragma. ===================================== ghc/GHCi/UI.hs ===================================== @@ -12,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-x-partial #-} {-# OPTIONS -fno-warn-name-shadowing #-} -- This module does a lot of it ===================================== ghc/Main.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS_GHC -Wno-x-partial #-} ----------------------------------------------------------------------------- -- ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -72,7 +72,10 @@ ghcWarningsArgs = do , package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ] , package stm ? pure [ "-Wno-deriving-typeable" ] , package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ] - , package parsec ? pure [ "-Wno-deriving-typeable" ] + , package parsec ? pure [ "-Wno-deriving-typeable" + , "-Wno-x-partial" + -- https://github.com/haskell/parsec/issues/194 + ] , package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ] -- The -Wno-incomplete-record-selectors is due to @@ -80,7 +83,9 @@ ghcWarningsArgs = do -- If that ticket is fixed, bwe can remove the flag again , package cabalSyntax ? pure [ "-Wno-deriving-typeable" ] - , package time ? pure [ "-Wno-deriving-typeable" ] + , package time ? pure [ "-Wno-deriving-typeable" + , "-Wno-x-partial" -- Awaiting time-1.15 release + ] , package transformers ? pure [ "-Wno-unused-matches" , "-Wno-unused-imports" , "-Wno-redundant-constraints" ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8 +Subproject commit 9a343d137bcc5ae97a8d6e7a670dd4fb67ea7294 ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe +Subproject commit 62e71a8f512a0f2a477d8004751ccf2420b8ac28 ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib import GHC.Boot.TH.Syntax import Data.Word ( Word8 ) import Data.Char ( toLower, chr ) -import Data.List ( intersperse ) +import Data.List ( intersperse, unsnoc ) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) @@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $ pprStms [s] = ppr s pprStms ss = braces (semiSep ss) -pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' -pprExp _ (CompE ss) = +pprExp _ (CompE ss) = case unsnoc ss of + Nothing -> text "<<Empty CompExp>>" + Just (ss', s) -> if null ss' -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. @@ -225,8 +226,6 @@ pprExp _ (CompE ss) = <+> bar <+> commaSep ss' <> text "]" - where s = last ss - ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -13,6 +13,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- For init in formatRealFloatAlt +{-# OPTIONS_GHC -Wno-x-partial #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Float ===================================== libraries/ghc-internal/src/GHC/Internal/List.hs ===================================== @@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a] tail (_:xs) = xs tail [] = errorEmptyList "tail" -{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} +{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} -- | $\mathcal{O}(n)$. Extract the last element of a list, which must be -- finite and non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs lastError :: HasCallStack => a lastError = errorEmptyList "last" +{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(n)$. Return all the elements of a list except the last one. -- The list must be non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -240,6 +254,8 @@ init (x:xs) = init' x xs where init' _ [] = [] init' y (z:zs) = y : init' z zs +{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(1)$. Test whether a list is empty. -- -- >>> null [] ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -840,11 +840,12 @@ output_flags = std_flags where -- XXX bits copied from System.FilePath, since that's not available here - combine a b - | null b = a - | null a = b - | pathSeparator [last a] = a ++ b - | otherwise = a ++ [pathSeparatorChar] ++ b + combine a [] = a + combine a b = case unsnoc a of + Nothing -> b + Just (_, lastA) + | pathSeparator [lastA] -> a ++ b + | otherwise -> a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable +import GHC.Internal.List (unsnoc) import GHC.Internal.Word import GHC.Internal.Generics (Generic) import GHC.Internal.IORef @@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix import GHC.Internal.Control.Exception import GHC.Internal.Num import GHC.Internal.IO.Unsafe -import GHC.Internal.List (dropWhile, break, replicate, reverse, last) +import GHC.Internal.List (dropWhile, break, replicate, reverse) import GHC.Internal.MVar import GHC.Internal.IO.Exception import GHC.Internal.Unicode @@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type) import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions +#ifdef BOOTSTRAP_TH +#if MIN_VERSION_base(4,19,0) +import Data.List (unsnoc) +#else +import Data.Maybe (maybe) +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +#endif +#endif + ----------------------------------------------------- -- -- The Quasi class @@ -1296,7 +1307,7 @@ mkName str -- (i.e. non-empty, starts with capital, all alpha) is_rev_mod_name rev_mod_str | (compt, rest) <- break (== '.') rev_mod_str - , not (null compt), isUpper (last compt), all is_mod_char compt + , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt = case rest of [] -> True (_dot : rest') -> is_rev_mod_name rest' ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Posix import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Windows import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== testsuite/tests/driver/j-space/jspace.hs ===================================== @@ -7,7 +7,7 @@ import System.Environment import GHC.Driver.Env.Types import GHC.Profiling import System.Mem -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, unsnoc) import Control.Monad import System.Exit import GHC.Platform @@ -41,7 +41,9 @@ initGhcM xs = do requestHeapCensus performGC [ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp" - let (n :: Int) = read (last (words ys)) + let (n :: Int) = case unsnoc (words ys) of + Nothing -> error "input is unexpectedly empty" + Just (_, lst) -> read lst -- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures): -- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH, -- and each ModDetails contains 1 (info table) + 8 word-sized fields. ===================================== testsuite/tests/rts/KeepCafsBase.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} + module KeepCafsBase (x) where x :: Int ===================================== utils/check-exact/Main.hs ===================================== @@ -6,6 +6,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-x-partial #-} import Data.Data import Data.List (intercalate) ===================================== utils/check-exact/Transform.hs ===================================== @@ -96,6 +96,7 @@ import GHC.Data.FastString import GHC.Types.SrcLoc import Data.Data +import Data.List (unsnoc) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe @@ -212,8 +213,9 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns ( where -- we want DPs for the distance from the end of the ns to the -- AnnDColon, and to the start of the ty - rd = case last ns of - L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc' + rd = case unsnoc ns of + Nothing -> error "unexpected empty list in 'ns' variable" + Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc' dca' = case dca of EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) []) _ -> dca @@ -294,7 +296,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp where cs'' = setPriorComments cs [] csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs' - lc = last $ (L ca c:cs') + lc = NE.last (L ca c :| cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r EpaSpan _ -> (SameLine 0) ===================================== utils/check-exact/Utils.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..)) import GHC.Parser.Lexer (allocateComments) import Data.Data hiding ( Fixity ) -import Data.List (sortBy, partition) +import Data.List (sortBy, partition, unsnoc) import qualified Data.Map.Strict as Map import Debug.Trace @@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h +glast info xs = case unsnoc xs of + Nothing -> error $ "glast " ++ info ++ " []" + Just (_, lst) -> lst gtail :: String -> [a] -> [a] gtail info [] = error $ "gtail " ++ info ++ " []" ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -8,7 +8,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-} -- Fine if this comes from make/Hadrian or the pre-built base. #include <ghcplatform.h> ===================================== utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs ===================================== @@ -1,6 +1,6 @@ module GHC.Toolchain.CheckArm ( findArmIsa ) where -import Data.List (isInfixOf) +import Data.List (isInfixOf, unsnoc) import Data.Maybe (catMaybes) import Control.Monad.IO.Class import System.Process @@ -76,8 +76,7 @@ findArmIsa cc = do _ -> throwE $ "unexpected output from test program: " ++ out lastLine :: String -> String -lastLine "" = "" -lastLine s = last $ lines s +lastLine = maybe "" snd . unsnoc . lines -- | Raspbian unfortunately makes some extremely questionable packaging -- decisions, configuring gcc to compile for ARMv6 despite the fact that the ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -755,7 +755,7 @@ ppHtmlIndex divAlphabet << unordList ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index + [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index ] ++ [merged_name] ) @@ -772,7 +772,7 @@ ppHtmlIndex writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part - index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c] + index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] index :: [(String, Map GHC.Name [(Module, Bool)])] index = sortBy cmp (Map.toAscList full_index) ===================================== utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs ===================================== @@ -30,7 +30,7 @@ import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) import Data.Functor (($>)) -import Data.List (elemIndex, intercalate, intersperse, unfoldr) +import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set @@ -870,10 +870,10 @@ codeblock = DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where - dropSpaces xs = - case splitByNl xs of - [] -> xs - ys -> case T.uncons (last ys) of + dropSpaces xs = let ys = splitByNl xs in + case unsnoc ys of + Nothing -> xs + Just (_, lastYs) -> case T.uncons lastYs of Just (' ', _) -> case mapM dropSpace ys of Nothing -> xs Just zs -> T.intercalate "\n" zs ===================================== utils/hpc ===================================== @@ -1 +1 @@ -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5 +Subproject commit dd43f7e139d7a4f4908d1e8af35a75939f763ef1 ===================================== utils/hsc2hs ===================================== @@ -1 +1 @@ -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8 +Subproject commit 2059c961fc28bbfd0cafdbef96d5d21f1d911b53 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a… You're receiving this email because of your account on gitlab.haskell.org.

1 0