[Git][ghc/ghc][master] Take more care in zonkEqTypes on AppTy/AppTy
by Marge Bot (＠marge-bot) 11 Aug '25
by Marge Bot (＠marge-bot) 11 Aug '25
11 Aug '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
18036d52 by Simon Peyton Jones at 2025-08-11T11:31:20-04:00
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
- - - - -
6 changed files:
- compiler/GHC/Tc/Solver/Equality.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -197,12 +197,8 @@ zonkEqTypes ev eq_rel ty1 ty2
then tycon tc1 tys1 tys2
else bale_out ty1 ty2
- go ty1 ty2
- | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
- , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
- = do { res_a <- go ty1a ty2a
- ; res_b <- go ty1b ty2b
- ; return $ combine_rev mkAppTy res_b res_a }
+ -- If you are temppted to add a case for AppTy/AppTy, be careful
+ -- See Note [zonkEqTypes and the PKTI]
go ty1@(LitTy lit1) (LitTy lit2)
| lit1 == lit2
@@ -278,6 +274,32 @@ zonkEqTypes ev eq_rel ty1 ty2
combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+{- Note [zonkEqTypes and the PKTI]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because `zonkEqTypes` does /partial/ zonking, we need to be very careful
+to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType
+HsNote [The Purely Kinded Type Invariant (PKTI)].
+
+In #26256 we try to solve this equality constraint:
+ Int :-> Maybe Char ~# k0 Int (m0 Char)
+where m0 and k0 are unification variables, and
+ m0 :: Type -> Type
+It happens that m0 was already unified
+ m0 := (w0 :: kappa)
+where kappa is another unification variable that is also already unified:
+ kappa := Type->Type.
+So the original type satisifed the PKTI, but a partially-zonked form
+ k0 Int (w0 Char)
+does not!! (This a bit reminiscent of Note [mkAppTyM].)
+
+The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`.
+After all, it's only supposed to be a quick hack to see if two types are already
+equal; if we bale out we'll just get into the "proper" canonicaliser.
+
+The only tricky thing about this approach is that it relies on /omitting/
+code -- for the AppTy/AppTy case! Hence this Note
+-}
+
{- *********************************************************************
* *
* canonicaliseEquality
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module M (go) where
+
+import Data.Kind
+
+type Apply :: (Type -> Type) -> Type
+data Apply m
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where (:->) = (->)
+
+f :: forall (k :: Type -> Type -> Type) (m :: Type -> Type).
+ k Int (m Char) -> k Bool (Apply m)
+f = f
+
+x :: Int :-> Maybe Char
+x = x
+
+go :: Bool -> _ _
+go = f x
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.stderr
=====================================
@@ -0,0 +1,8 @@
+T26256.hs:22:15: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Apply :: (* -> *) -> *’
+ • In the type signature: go :: Bool -> _ _
+
+T26256.hs:22:17: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Maybe :: * -> *’
+ • In the first argument of ‘_’, namely ‘_’
+ In the type signature: go :: Bool -> _ _
=====================================
testsuite/tests/partial-sigs/should_compile/all.T
=====================================
@@ -108,3 +108,4 @@ test('T21667', normal, compile, [''])
test('T22065', normal, compile, [''])
test('T16152', normal, compile, [''])
test('T20076', expect_broken(20076), compile, [''])
+test('T26256', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_compile/T26256a.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T26256 (go) where
+
+import Data.Kind
+
+class Cat k where (<<<) :: k a b -> k x a -> k x b
+instance Cat (->) where (<<<) = (.)
+class Pro k p where pro :: k a b s t -> p a b -> p s t
+data Hiding o a b s t = forall e. Hiding (s -> o e a)
+newtype Apply e a = Apply (e a)
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where
+ (:->) = (->)
+
+go :: (Pro (Hiding Apply) p) => (s :-> e a) -> p a b -> p s t
+go sea = pro (Hiding (Apply <<< sea))
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -940,3 +940,4 @@ test('T26020', normal, compile, [''])
test('T26020a', [extra_files(['T26020a_help.hs'])], multimod_compile, ['T26020a', '-v0'])
test('T25992', normal, compile, [''])
test('T14010', normal, compile, [''])
+test('T26256a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18036d5205ac648bb245217519fed2f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18036d5205ac648bb245217519fed2f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23109] 15 commits: Handle non-fractional CmmFloats in Cmm's CBE (#26229)
by Ben Gamari (＠bgamari) 11 Aug '25
by Ben Gamari (＠bgamari) 11 Aug '25
11 Aug '25
Ben Gamari pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
03555ed8 by Sylvain Henry at 2025-08-10T22:20:57-04:00
Handle non-fractional CmmFloats in Cmm's CBE (#26229)
Since f8d9d016305be355f518c141f6c6d4826f2de9a2, toRational for Float and
Double converts float's infinity and NaN into Rational's infinity and
NaN (respectively 1%0 and 0%0).
Cmm CommonBlockEliminator hashing function needs to take these values
into account as they can appear as literals now. See added testcase.
- - - - -
6c956af3 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00
Fix extensions list in `DoAndIfThenElse` docs
- - - - -
6dc420b1 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00
Document status of `RelaxedPolyRec` extension
This adds a brief extension page explaining the status of the
`RelaxedPolyRec` extension. The behaviour of this mode is already
explained elsewhere, so this page is mainly for completeness so that
various lists of extensions have somewhere to point to for this flag.
Fixes #18630
- - - - -
b73b3f17 by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Make injecting implicit bindings into its own pass
Previously we were injecting "impliicit bindings" (data constructor
worker and wrappers etc)
- both at the end of CoreTidy,
- and at the start of CorePrep
This is unpleasant and confusing. This patch puts it it its own pass,
addImplicitBinds, which runs between the two.
The function `GHC.CoreToStg.AddImplicitBinds.addImplicitBinds` now takes /all/
TyCons, not just the ones for algebraic data types. That change ripples
through to
- corePrepPgm
- doCodeGen
- byteCodeGen
All take [TyCon] which includes all TyCons
- - - - -
43c93a7d by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Implement unary classes
The big change is described exhaustively in
Note [Unary class magic] in GHC.Core.TyCon
Other changes
* We never unbox class dictionaries in worker/wrapper. This has been true for some
time now, but the logic is now centralised in functions in
GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg`
See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils.
* Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels.
I can't remember if I actually changed any behaviour here, but if so it's
only in a corner cases.
* Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning
True for (##).
* Remove redundant Role argument to `liftCoSubstWithEx`. It was always
Representational.
* I refactored evidence generation in the constraint solver:
* Made GHC.Tc.Types.Evidence contain better abstactions for evidence
generation.
* I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents
elsewhere. It wasn't paying its way.
* Made evidence for implicit parameters go via a proper abstraction.
* Fix inlineBoringOk; see (IB6) in Note [inlineBoringOk]
This fixes a slowdown in `countdownEffectfulDynLocal`
in the `effectful` library.
Smaller things
* Rename `isDataTyCon` to `isBoxedDataTyCon`.
* GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role,
so I baked that into the function and removed the argument.
* Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling
`not isNewTyCon` at the call sites; more explicit.
* Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its
behaviour
* Moved `decomposeIPPred` to GHC.Core.Predicate
Compile time performance changes:
geo. mean +0.1%
minimum -6.8%
maximum +14.4%
The +14% one is in T21839c, where it seems that a bit more inlining
is taking place. That seems acceptable; and the average change is small
Metric Decrease:
LargeRecord
T12227
T16577
T21839r
T5642
Metric Increase:
T15164
T21839c
T3294
T5321FD
T5321Fun
WWRec
- - - - -
0c9acb5e by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Accept GHCi debugger output change
@alt-romes says this is fine
- - - - -
92f4dc66 by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Small hacky fix to specUnfolding
...just using mkApps instead of mkCoreApps
(This part is likely to change again in a
future commit.)
- - - - -
62ac0bdc by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Slight improvement to pre/postInlineUnconditionally
Avoids an extra simplifier iteration
- - - - -
c8258401 by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Fix a long-standing assertion error in normSplitTyConApp_maybe
- - - - -
b8bc92b3 by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Add comment to coercion optimiser
- - - - -
9c1e4f89 by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Fix mergo bugs
- - - - -
5c30a79a by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Wibble imports
- - - - -
3a7ce66e by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Fix specialiser
..needs documentation
- - - - -
d8a6fccf by Simon Peyton Jones at 2025-08-11T15:21:15+00:00
Wibbles
- - - - -
bba4f666 by Ben Gamari at 2025-08-11T15:21:15+00:00
Move addImplicitBinds
- - - - -
103 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Core/Class.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg.hs
- + compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- − compiler/GHC/Tc/Types/EvTerm.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Types/TyThing.hs
- compiler/ghc.cabal.in
- docs/users_guide/conf.py
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/exts/doandifthenelse.rst
- + docs/users_guide/exts/relaxed_poly_rec.rst
- docs/users_guide/exts/types.rst
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/dmdanal/should_compile/T16029.stdout
- testsuite/tests/dmdanal/sigs/T21119.stderr
- testsuite/tests/dmdanal/sigs/T21888.stderr
- testsuite/tests/ghci.debugger/scripts/break011.stdout
- testsuite/tests/ghci.debugger/scripts/break024.stdout
- testsuite/tests/indexed-types/should_compile/T2238.hs
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/numeric/should_compile/T23907.stderr
- + testsuite/tests/numeric/should_compile/T26229.hs
- testsuite/tests/numeric/should_compile/all.T
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T17366.stderr
- testsuite/tests/simplCore/should_compile/T17966.stderr
- testsuite/tests/simplCore/should_compile/T22309.stderr
- testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr
- testsuite/tests/simplCore/should_compile/T23307.stderr
- testsuite/tests/simplCore/should_compile/T23307a.stderr
- testsuite/tests/simplCore/should_compile/T25389.stderr
- testsuite/tests/simplCore/should_compile/T25713.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/tcplugins/CtIdPlugin.hs
- testsuite/tests/typecheck/should_compile/Makefile
- testsuite/tests/typecheck/should_compile/T12763.stderr
- testsuite/tests/typecheck/should_compile/T14774.stdout
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/unboxedsums/unpack_sums_7.stdout
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- testsuite/tests/wasm/should_run/control-flow/RunWasm.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/977ee0da9ef57ff73b7ac229d288a9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/977ee0da9ef57ff73b7ac229d288a9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/linker_fix] rts: Linker.c - Fail properly if loadObj fails to verify object.
by Andreas Klebinger (＠AndreasK) 11 Aug '25
by Andreas Klebinger (＠AndreasK) 11 Aug '25
11 Aug '25
Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC
Commits:
3e1ed449 by Andreas Klebinger at 2025-08-11T15:35:54+02:00
rts: Linker.c - Fail properly if loadObj fails to verify object.
- - - - -
1 changed file:
- rts/Linker.c
Changes:
=====================================
rts/Linker.c
=====================================
@@ -1441,7 +1441,11 @@ preloadObjectFile (pathchar *path)
/* FIXME (AP): =mapped= parameter unconditionally set to true */
oc = mkOc(STATIC_OBJECT, path, image, fileSize, true, NULL, misalignment);
- verifyAndInitOc(oc);
+ if (!verifyAndInitOc(oc)) {
+ freeObjectCode(oc);
+ debugBelch("loadObj: Failed to verify oc.\n");
+ return NULL;
+ };
return oc;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e1ed4499ca6b6bb0fe51fe69d83335…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e1ed4499ca6b6bb0fe51fe69d83335…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26295] Allow defining HasField instances for naughty fields
by Oleg Grenrus (＠phadej) 11 Aug '25
by Oleg Grenrus (＠phadej) 11 Aug '25
11 Aug '25
Oleg Grenrus pushed to branch wip/T26295 at Glasgow Haskell Compiler / GHC
Commits:
ee2a0594 by Oleg Grenrus at 2025-08-11T12:23:32+03:00
Allow defining HasField instances for naughty fields
Resolves #26295
... as HasField solver doesn't solve for fields with "naughty"
selectors, we could as well allow defining HasField instances for these
fields.
- - - - -
4 changed files:
- compiler/GHC/Tc/Validity.hs
- + testsuite/tests/overloadedrecflds/should_run/T26295.hs
- + testsuite/tests/overloadedrecflds/should_run/T26295.stdout
- testsuite/tests/overloadedrecflds/should_run/all.T
Changes:
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank
import GHC.Tc.Errors.Types
+import GHC.Tc.Utils.Env (tcLookupId)
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
import GHC.Tc.Zonk.TcType
@@ -60,6 +61,8 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Error
import GHC.Types.Basic ( TypeOrKind(..), UnboxedTupleOrSum(..)
, unboxedTupleOrSumExtension )
+import GHC.Types.Id (isNaughtyRecordSelector)
+import GHC.Types.FieldLabel (flSelector)
import GHC.Types.Name
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -1718,8 +1721,17 @@ checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] =
| otherwise -> case isStrLitTy lbl_ty of
Just lbl
| let lbl_str = FieldLabelString lbl
- , isJust (lookupTyConFieldLabel lbl_str tc)
- -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
+ , Just fl <- lookupTyConFieldLabel lbl_str tc
+ -> do
+ -- GHC does not provide HasField instances for naughty record selectors
+ -- (see Note [Naughty record selectors] in GHC.Tc.TyCl.Utils),
+ -- so don't prevent the user from writing such instances.
+ -- See GHC.Tc.Instance.Class.matchHasField.
+ -- Test case: T26295.
+ sel_id <- tcLookupId $ flSelector fl
+ if isNaughtyRecordSelector sel_id
+ then return ()
+ else add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
| otherwise
-> return ()
Nothing
=====================================
testsuite/tests/overloadedrecflds/should_run/T26295.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE UndecidableInstances #-}
+import GHC.Records
+
+-- large-records mangles record definitions to look like below to
+-- prevent selector function generation (even implicit ones)
+data R = forall a b. (a ~ Int, b ~ Char) => MkR
+ { field_a :: a
+ , field_b :: b
+ }
+
+-- fields in R are naughty, so we can define custom HasField instancs for them
+instance a ~ Int => HasField "field_a" R a where
+ getField (MkR a _) = a
+
+ex :: Int
+ex = r.field_a
+ where
+ r :: R
+ r = MkR 42 'x'
+
+main :: IO ()
+main = print ex
=====================================
testsuite/tests/overloadedrecflds/should_run/T26295.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/overloadedrecflds/should_run/all.T
=====================================
@@ -20,3 +20,4 @@ test('T12243', normal, compile_and_run, [''])
test('T11228', normal, compile_and_run, [''])
test('T11671_run', normal, compile_and_run, [''])
test('T17551b', [req_th], compile_and_run, [''])
+test('T26295', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee2a059446c385c492cfed1caa6a4cb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee2a059446c385c492cfed1caa6a4cb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26295] Allow definining HasField instances for naughty fields
by Oleg Grenrus (＠phadej) 11 Aug '25
by Oleg Grenrus (＠phadej) 11 Aug '25
11 Aug '25
Oleg Grenrus pushed to branch wip/T26295 at Glasgow Haskell Compiler / GHC
Commits:
a6237d55 by Oleg Grenrus at 2025-08-11T12:23:01+03:00
Allow definining HasField instances for naughty fields
Resolves #26295
... as HasField solver doesn't solve for fields with "naughty"
selectors, we could as well allow defining HasField instances for these
fields.
- - - - -
4 changed files:
- compiler/GHC/Tc/Validity.hs
- + testsuite/tests/overloadedrecflds/should_run/T26295.hs
- + testsuite/tests/overloadedrecflds/should_run/T26295.stdout
- testsuite/tests/overloadedrecflds/should_run/all.T
Changes:
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank
import GHC.Tc.Errors.Types
+import GHC.Tc.Utils.Env (tcLookupId)
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
import GHC.Tc.Zonk.TcType
@@ -60,6 +61,8 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Error
import GHC.Types.Basic ( TypeOrKind(..), UnboxedTupleOrSum(..)
, unboxedTupleOrSumExtension )
+import GHC.Types.Id (isNaughtyRecordSelector)
+import GHC.Types.FieldLabel (flSelector)
import GHC.Types.Name
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -1718,8 +1721,17 @@ checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] =
| otherwise -> case isStrLitTy lbl_ty of
Just lbl
| let lbl_str = FieldLabelString lbl
- , isJust (lookupTyConFieldLabel lbl_str tc)
- -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
+ , Just fl <- lookupTyConFieldLabel lbl_str tc
+ -> do
+ -- GHC does not provide HasField instances for naughty record selectors
+ -- (see Note [Naughty record selectors] in GHC.Tc.TyCl.Utils),
+ -- so don't prevent the user from writing such instances.
+ -- See GHC.Tc.Instance.Class.matchHasField.
+ -- Test case: T26295.
+ sel_id <- tcLookupId $ flSelector fl
+ if isNaughtyRecordSelector sel_id
+ then return ()
+ else add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
| otherwise
-> return ()
Nothing
=====================================
testsuite/tests/overloadedrecflds/should_run/T26295.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE UndecidableInstances #-}
+import GHC.Records
+
+-- large-records mangles record definitions to look like below to
+-- prevent selector function generation (even implicit ones)
+data R = forall a b. (a ~ Int, b ~ Char) => MkR
+ { field_a :: a
+ , field_b :: b
+ }
+
+-- fields in R are naughty, so we can define custom HasField instancs for them
+instance a ~ Int => HasField "field_a" R a where
+ getField (MkR a _) = a
+
+ex :: Int
+ex = r.field_a
+ where
+ r :: R
+ r = MkR 42 'x'
+
+main :: IO ()
+main = print ex
=====================================
testsuite/tests/overloadedrecflds/should_run/T26295.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/overloadedrecflds/should_run/all.T
=====================================
@@ -20,3 +20,4 @@ test('T12243', normal, compile_and_run, [''])
test('T11228', normal, compile_and_run, [''])
test('T11671_run', normal, compile_and_run, [''])
test('T17551b', [req_th], compile_and_run, [''])
+test('T26295', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6237d55c43fe172245817cbd3f5927…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6237d55c43fe172245817cbd3f5927…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Aug '25
Oleg Grenrus pushed to branch wip/T26295 at Glasgow Haskell Compiler / GHC
Commits:
a05f102c by Oleg Grenrus at 2025-08-11T09:22:39+00:00
Apply 2 suggestion(s) to 2 file(s)
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
2 changed files:
- compiler/GHC/Tc/Validity.hs
- testsuite/tests/overloadedrecflds/should_run/T26295.hs
Changes:
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -1723,8 +1723,11 @@ checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] =
| let lbl_str = FieldLabelString lbl
, Just fl <- lookupTyConFieldLabel lbl_str tc
-> do
- -- this logic vaguely mirrors 'matchHasField',
- -- generally we should allow to define HasField instances which GHC will not solve for.
+ -- GHC does not provide HasField instances for naughty record selectors
+ -- (see Note [Naughty record selectors] in GHC.Tc.TyCl.Utils),
+ -- so don't prevent the user from writing such instances.
+ -- See GHC.Tc.Instance.Class.matchHasField.
+ -- Test case: T26295.
sel_id <- tcLookupId $ flSelector fl
if isNaughtyRecordSelector sel_id
then return ()
=====================================
testsuite/tests/overloadedrecflds/should_run/T26295.hs
=====================================
@@ -12,7 +12,7 @@ data R = forall a b. (a ~ Int, b ~ Char) => MkR
, field_b :: b
}
--- fields in R are naught, so we can define own HasField instances for them.
+-- fields in R are naughty, so we can define custom HasField instancs for them
instance a ~ Int => HasField "field_a" R a where
getField (MkR a _) = a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05f102c5e5fcdb99457914c4422499…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05f102c5e5fcdb99457914c4422499…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] compiler: implement and test bytecode serialization logic
by Cheng Shao (＠TerrorJack) 11 Aug '25
by Cheng Shao (＠TerrorJack) 11 Aug '25
11 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
dfad5e2e by Cheng Shao at 2025-08-11T08:43:48+00:00
compiler: implement and test bytecode serialization logic
- - - - -
14 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/Data/SmallArray.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
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,10 +53,12 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
+import GHC.Data.SmallArray
{-
************************************************************************
@@ -929,3 +931,12 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOpsArr `indexSmallArray`) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
+
+allThePrimOpsArr :: SmallArray PrimOp
+{-# NOINLINE allThePrimOpsArr #-}
+allThePrimOpsArr = listToArray (maxPrimOpTag + 1) primOpTag id allThePrimOps
=====================================
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,205 @@
+{-# 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.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.Panic
+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 <- addBinNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addBinNameWriter 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 <- getViaBinName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaBinName 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
+ putViaBinName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaBinName bh
+ <*> get bh
+ <*> (Binary.decode <$> get bh)
+ <*> (Binary.decode <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaBinName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaBinName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ 3 -> BCOPtrBreakArray <$> get bh
+ _ -> panic "Binary BCOPtr: invalid byte"
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaBinName 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 <$> getViaBinName bh
+ 3 -> BCONPtrAddr <$> getViaBinName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ 7 -> BCONPtrCostCentre <$> get bh
+ _ -> panic "Binary BCONPtr: invalid byte"
+
+ 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 *> putViaBinName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaBinName 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 BinName = BinName {unBinName :: Name}
+
+getViaBinName :: ReadBinHandle -> IO Name
+getViaBinName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unBinName <$> f bh
+
+putViaBinName :: WriteBinHandle -> Name -> IO ()
+putViaBinName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ BinName nm
+
+addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addBinNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (BinName 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)
+
+addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addBinNameReader HscEnv {..} bh' = do
+ env_ref <- newIORef emptyOccEnv
+ pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ pure $ BinName nm
+ 1 -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache hsc_NC
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap BinName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
+ _ -> panic "Binary BinName: invalid byte"
+
+-- Note [Serializing Names in bytecode]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The bytecode related types contain various Names which we need to
+-- serialize. Unfortunately, we can't directly use the Binary instance
+-- of Name: it is only meant to be used for serializing external Names
+-- in BinIface logic, but bytecode does contain internal Names.
+--
+-- We also need to maintain the invariant that: any pair of internal
+-- Names with equal/different uniques must also be deserialized to
+-- have the same equality. So normally uniques aren't supposed to be
+-- serialized, but for this invariant to work, we do append uniques to
+-- OccNames of internal Names, so that they can be uniquely identified
+-- by OccName alone. When deserializing, we check a global cached
+-- mapping from OccName to Unique, and create the real Name with the
+-- right Unique if it's already deserialized at least once.
=====================================
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.Panic
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,21 @@ 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
+ t <- getByte bh
+ case t of
+ 0 -> pure EmptyFlatBag
+ 1 -> UnitFlatBag <$> get bh
+ 2 -> TupleFlatBag <$> get bh <*> get bh
+ 3 -> FlatBag <$> get bh
+ _ -> panic "Binary FlatBag: invalid byte"
+
+ put_ bh EmptyFlatBag = putByte bh 0
+ put_ bh (UnitFlatBag a) = putByte bh 1 *> put_ bh a
+ put_ bh (TupleFlatBag a b) = putByte bh 2 *> put_ bh a *> put_ bh b
+ put_ bh (FlatBag arr) = putByte bh 3 *> put_ bh arr
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +146,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Data/SmallArray.hs
=====================================
@@ -29,7 +29,9 @@ import GHC.Exts
import GHC.Prelude
import GHC.IO
import GHC.ST
+import GHC.Utils.Binary
import Control.DeepSeq
+import Data.Foldable
data SmallArray a = SmallArray (SmallArray# a)
@@ -166,3 +168,17 @@ listToArray (I# size) index_of value_of xs = runST $ ST \s ->
(# s', ma #) -> case write_elems ma xs s' of
s'' -> case unsafeFreezeSmallArray# ma s'' of
(# s''', a #) -> (# s''', SmallArray a #)
+
+instance (Binary a) => Binary (SmallArray a) where
+ get bh = do
+ len <- get bh
+ ma <- newSmallArrayIO len undefined
+ for_ [0 .. len - 1] $ \i -> do
+ a <- get bh
+ writeSmallArrayIO ma i a
+ unsafeFreezeSmallArrayIO ma
+
+ put_ bh sa = do
+ let len = sizeofSmallArray sa
+ put_ bh len
+ for_ [0 .. len - 1] $ \i -> put_ bh $ sa `indexSmallArray` i
=====================================
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,9 +3,14 @@ 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
+import GHC.Utils.Panic.Plain
-- | An entry to be inserted into a module's static pointer table.
-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
@@ -14,3 +19,13 @@ 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
+ -- static pointer logic only uses the associated Name without Type
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry var fp) = do
+ massert $ isGlobalId var
+ put_ bh (getName var) *> 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
@@ -1849,6 +1860,18 @@ instance Binary ByteString where
put_ bh f = putBS bh f
get bh = getBS bh
+instance Binary LBS.ByteString where
+ put_ bh lbs = do
+ put_ bh (fromIntegral (LBS.length lbs) :: Int)
+ let f bs acc =
+ ( BS.unsafeUseAsCStringLen bs $
+ \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l
+ )
+ *> acc
+ LBS.foldrChunks f (pure ()) lbs
+
+ get bh = LBS.fromStrict <$> get bh
+
instance Binary FastString where
put_ bh f =
case findUserDataWriter (Proxy :: Proxy FastString) bh of
@@ -2106,6 +2129,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 +2187,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 <$> get bh
+
+ put_ bh = put_ bh . 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
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -73,6 +73,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfad5e2ec454dd05ea720def9a001b4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfad5e2ec454dd05ea720def9a001b4…
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) 11 Aug '25
by Cheng Shao (＠TerrorJack) 11 Aug '25
11 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
1286aefe by Cheng Shao at 2025-08-11T07:38:39+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
18e8f955 by Cheng Shao at 2025-08-11T07:38:44+00:00
driver: test bytecode roundtrip serialization
- - - - -
14 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/Data/SmallArray.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
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,10 +53,12 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
+import GHC.Data.SmallArray
{-
************************************************************************
@@ -929,3 +931,12 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOpsArr `indexSmallArray`) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
+
+allThePrimOpsArr :: SmallArray PrimOp
+{-# NOINLINE allThePrimOpsArr #-}
+allThePrimOpsArr = listToArray (maxPrimOpTag + 1) primOpTag id allThePrimOps
=====================================
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,186 @@
+{-# 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.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 <$> get bh)
+ <*> (Binary.decode <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ 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.Panic
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,21 @@ 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
+ t <- getByte bh
+ case t of
+ 0 -> pure EmptyFlatBag
+ 1 -> UnitFlatBag <$> get bh
+ 2 -> TupleFlatBag <$> get bh <*> get bh
+ 3 -> FlatBag <$> get bh
+ _ -> panic "Binary FlatBag: invalid byte"
+
+ put_ bh EmptyFlatBag = putByte bh 0
+ put_ bh (UnitFlatBag a) = putByte bh 1 *> put_ bh a
+ put_ bh (TupleFlatBag a b) = putByte bh 2 *> put_ bh a *> put_ bh b
+ put_ bh (FlatBag arr) = putByte bh 3 *> put_ bh arr
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +146,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Data/SmallArray.hs
=====================================
@@ -29,7 +29,9 @@ import GHC.Exts
import GHC.Prelude
import GHC.IO
import GHC.ST
+import GHC.Utils.Binary
import Control.DeepSeq
+import Data.Foldable
data SmallArray a = SmallArray (SmallArray# a)
@@ -166,3 +168,17 @@ listToArray (I# size) index_of value_of xs = runST $ ST \s ->
(# s', ma #) -> case write_elems ma xs s' of
s'' -> case unsafeFreezeSmallArray# ma s'' of
(# s''', a #) -> (# s''', SmallArray a #)
+
+instance (Binary a) => Binary (SmallArray a) where
+ get bh = do
+ len <- get bh
+ ma <- newSmallArrayIO len undefined
+ for_ [0 .. len - 1] $ \i -> do
+ a <- get bh
+ writeSmallArrayIO ma i a
+ unsafeFreezeSmallArrayIO ma
+
+ put_ bh sa = do
+ let len = sizeofSmallArray sa
+ put_ bh len
+ for_ [0 .. len - 1] $ \i -> put_ bh $ sa `indexSmallArray` i
=====================================
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
@@ -1849,6 +1860,18 @@ instance Binary ByteString where
put_ bh f = putBS bh f
get bh = getBS bh
+instance Binary LBS.ByteString where
+ put_ bh lbs = do
+ put_ bh (fromIntegral (LBS.length lbs) :: Int)
+ let f bs acc =
+ ( BS.unsafeUseAsCStringLen bs $
+ \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l
+ )
+ *> acc
+ LBS.foldrChunks f (pure ()) lbs
+
+ get bh = LBS.fromStrict <$> get bh
+
instance Binary FastString where
put_ bh f =
case findUserDataWriter (Proxy :: Proxy FastString) bh of
@@ -2106,6 +2129,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 +2187,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 <$> get bh
+
+ put_ bh = put_ bh . 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
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -73,6 +73,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/806b69e52c7ab779f21488ca87be26…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/806b69e52c7ab779f21488ca87be26…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Handle non-fractional CmmFloats in Cmm's CBE (#26229)
by Marge Bot (＠marge-bot) 11 Aug '25
by Marge Bot (＠marge-bot) 11 Aug '25
11 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
03555ed8 by Sylvain Henry at 2025-08-10T22:20:57-04:00
Handle non-fractional CmmFloats in Cmm's CBE (#26229)
Since f8d9d016305be355f518c141f6c6d4826f2de9a2, toRational for Float and
Double converts float's infinity and NaN into Rational's infinity and
NaN (respectively 1%0 and 0%0).
Cmm CommonBlockEliminator hashing function needs to take these values
into account as they can appear as literals now. See added testcase.
- - - - -
6c956af3 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00
Fix extensions list in `DoAndIfThenElse` docs
- - - - -
6dc420b1 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00
Document status of `RelaxedPolyRec` extension
This adds a brief extension page explaining the status of the
`RelaxedPolyRec` extension. The behaviour of this mode is already
explained elsewhere, so this page is mainly for completeness so that
various lists of extensions have somewhere to point to for this flag.
Fixes #18630
- - - - -
0927bda0 by Simon Peyton Jones at 2025-08-11T03:30:50-04:00
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
- - - - -
e7755f73 by Zubin Duggal at 2025-08-11T03:30:51-04:00
ci: upgrade bootstrap compiler on windows to 9.10.1
- - - - -
16 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Tc/Solver/Equality.hs
- docs/users_guide/conf.py
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/exts/doandifthenelse.rst
- + docs/users_guide/exts/relaxed_poly_rec.rst
- docs/users_guide/exts/types.rst
- + testsuite/tests/numeric/should_compile/T26229.hs
- testsuite/tests/numeric/should_compile/all.T
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -478,7 +478,7 @@ opsysVariables _ (Windows {}) = mconcat
, "LANG" =: "en_US.UTF-8"
, "CABAL_INSTALL_VERSION" =: "3.10.2.0"
, "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
- , "GHC_VERSION" =: "9.6.4"
+ , "GHC_VERSION" =: "9.10.1"
]
opsysVariables _ _ = mempty
=====================================
.gitlab/jobs.yaml
=====================================
@@ -3698,7 +3698,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -3761,7 +3761,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -5579,7 +5579,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -5643,7 +5643,7 @@
"BUILD_FLAVOUR": "release",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
@@ -7982,7 +7982,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
@@ -8044,7 +8044,7 @@
"BUILD_FLAVOUR": "validate",
"CABAL_INSTALL_VERSION": "3.10.2.0",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
- "GHC_VERSION": "9.6.4",
+ "GHC_VERSION": "9.10.1",
"HADRIAN_ARGS": "--docs=no-sphinx-pdfs",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"LANG": "en_US.UTF-8",
=====================================
compiler/GHC/Cmm/CommonBlockElim.hs
=====================================
@@ -29,6 +29,7 @@ import GHC.Utils.Word64 (truncateWord64ToWord32)
import Control.Arrow (first, second)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
+import GHC.Real (infinity,notANumber)
-- -----------------------------------------------------------------------------
-- Eliminate common blocks
@@ -167,7 +168,12 @@ hash_block block =
hash_lit :: CmmLit -> Word32
hash_lit (CmmInt i _) = fromInteger i
- hash_lit (CmmFloat r _) = truncate r
+ hash_lit (CmmFloat r _)
+ -- handle these special cases as `truncate` fails on non-fractional numbers (#26229)
+ | r == infinity = 9999999
+ | r == -infinity = 9999998
+ | r == notANumber = 6666666
+ | otherwise = truncate r
hash_lit (CmmVec ls) = hash_list hash_lit ls
hash_lit (CmmLabel _) = 119 -- ugh
hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -197,12 +197,8 @@ zonkEqTypes ev eq_rel ty1 ty2
then tycon tc1 tys1 tys2
else bale_out ty1 ty2
- go ty1 ty2
- | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
- , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
- = do { res_a <- go ty1a ty2a
- ; res_b <- go ty1b ty2b
- ; return $ combine_rev mkAppTy res_b res_a }
+ -- If you are temppted to add a case for AppTy/AppTy, be careful
+ -- See Note [zonkEqTypes and the PKTI]
go ty1@(LitTy lit1) (LitTy lit2)
| lit1 == lit2
@@ -278,6 +274,32 @@ zonkEqTypes ev eq_rel ty1 ty2
combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+{- Note [zonkEqTypes and the PKTI]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because `zonkEqTypes` does /partial/ zonking, we need to be very careful
+to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType
+HsNote [The Purely Kinded Type Invariant (PKTI)].
+
+In #26256 we try to solve this equality constraint:
+ Int :-> Maybe Char ~# k0 Int (m0 Char)
+where m0 and k0 are unification variables, and
+ m0 :: Type -> Type
+It happens that m0 was already unified
+ m0 := (w0 :: kappa)
+where kappa is another unification variable that is also already unified:
+ kappa := Type->Type.
+So the original type satisifed the PKTI, but a partially-zonked form
+ k0 Int (w0 Char)
+does not!! (This a bit reminiscent of Note [mkAppTyM].)
+
+The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`.
+After all, it's only supposed to be a quick hack to see if two types are already
+equal; if we bale out we'll just get into the "proper" canonicaliser.
+
+The only tricky thing about this approach is that it relies on /omitting/
+code -- for the AppTy/AppTy case! Hence this Note
+-}
+
{- *********************************************************************
* *
* canonicaliseEquality
=====================================
docs/users_guide/conf.py
=====================================
@@ -35,8 +35,6 @@ nitpick_ignore = [
("envvar", "TMPDIR"),
("c:type", "bool"),
-
- ("extension", "RelaxedPolyRec"),
]
rst_prolog = """
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -14,7 +14,6 @@
-XPolymorphicComponents
-XRecordPuns
-XRelaxedLayout
--XRelaxedPolyRec
-copy-libs-when-linking
-dannot-lint
-dppr-ticks
=====================================
docs/users_guide/exts/doandifthenelse.rst
=====================================
@@ -8,7 +8,7 @@ Do And If Then Else
:since: 7.0.1
- :status: Included in :extension:`Haskell2010`
+ :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010`
Allow semicolons in ``if`` expressions.
=====================================
docs/users_guide/exts/relaxed_poly_rec.rst
=====================================
@@ -0,0 +1,17 @@
+.. _relaxed-poly-rec:
+
+Generalised typing of mutually recursive bindings
+-------------------------------------------------
+
+.. extension:: RelaxedPolyRec
+ :shortdesc: Generalised typing of mutually recursive bindings.
+
+ :since: 6.8.1
+
+ :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010`
+
+See :ref:`infelicities-recursive-groups` for a description of this extension.
+This is a long-standing GHC extension. Around the time of GHC 7.6.3, this
+extension became required as part of a typechecker refactoring.
+The ``-XRelaxedPolyRec`` flag is now deprecated (since the feature is always
+enabled) and may be removed at some future time.
=====================================
docs/users_guide/exts/types.rst
=====================================
@@ -30,3 +30,4 @@ Types
type_errors
defer_type_errors
roles
+ relaxed_poly_rec
=====================================
testsuite/tests/numeric/should_compile/T26229.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE NegativeLiterals #-}
+
+module T26229 where
+
+sqrte2pqiq :: (Floating a, Ord a) => a -> a -> a
+sqrte2pqiq e qiq -- = sqrt (e*e + qiq)
+ | e < - 1.5097698010472593e153 = -(qiq/e) - e
+ | e < 5.582399551122541e57 = sqrt (e*e + qiq) -- test Infinity#
+ | e < -5.582399551122541e57 = -sqrt (e*e + qiq) -- test -Infinity#
+ | otherwise = (qiq/e) + e
+{-# SPECIALIZE sqrte2pqiq :: Double -> Double -> Double #-}
+{-# SPECIALIZE sqrte2pqiq :: Float -> Float -> Float #-}
=====================================
testsuite/tests/numeric/should_compile/all.T
=====================================
@@ -22,3 +22,4 @@ test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b
test('T23019', normal, compile, ['-O'])
test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
test('T24331', normal, compile, ['-O -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds'])
+test('T26229', normal, compile, ['-O2'])
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module M (go) where
+
+import Data.Kind
+
+type Apply :: (Type -> Type) -> Type
+data Apply m
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where (:->) = (->)
+
+f :: forall (k :: Type -> Type -> Type) (m :: Type -> Type).
+ k Int (m Char) -> k Bool (Apply m)
+f = f
+
+x :: Int :-> Maybe Char
+x = x
+
+go :: Bool -> _ _
+go = f x
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.stderr
=====================================
@@ -0,0 +1,8 @@
+T26256.hs:22:15: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Apply :: (* -> *) -> *’
+ • In the type signature: go :: Bool -> _ _
+
+T26256.hs:22:17: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Maybe :: * -> *’
+ • In the first argument of ‘_’, namely ‘_’
+ In the type signature: go :: Bool -> _ _
=====================================
testsuite/tests/partial-sigs/should_compile/all.T
=====================================
@@ -108,3 +108,4 @@ test('T21667', normal, compile, [''])
test('T22065', normal, compile, [''])
test('T16152', normal, compile, [''])
test('T20076', expect_broken(20076), compile, [''])
+test('T26256', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_compile/T26256a.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T26256 (go) where
+
+import Data.Kind
+
+class Cat k where (<<<) :: k a b -> k x a -> k x b
+instance Cat (->) where (<<<) = (.)
+class Pro k p where pro :: k a b s t -> p a b -> p s t
+data Hiding o a b s t = forall e. Hiding (s -> o e a)
+newtype Apply e a = Apply (e a)
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where
+ (:->) = (->)
+
+go :: (Pro (Hiding Apply) p) => (s :-> e a) -> p a b -> p s t
+go sea = pro (Hiding (Apply <<< sea))
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -940,3 +940,4 @@ test('T26020', normal, compile, [''])
test('T26020a', [extra_files(['T26020a_help.hs'])], multimod_compile, ['T26020a', '-v0'])
test('T25992', normal, compile, [''])
test('T14010', normal, compile, [''])
+test('T26256a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/464c54b8490fbb21049cc184bd1fac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/464c54b8490fbb21049cc184bd1fac…
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) 11 Aug '25
by Cheng Shao (＠TerrorJack) 11 Aug '25
11 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
bf7738d9 by Cheng Shao at 2025-08-11T07:07:03+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
806b69e5 by Cheng Shao at 2025-08-11T07:07:06+00:00
driver: test bytecode roundtrip serialization
- - - - -
13 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
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,10 +53,12 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
+import GHC.Data.SmallArray
{-
************************************************************************
@@ -929,3 +931,12 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOpsArr `indexSmallArray`) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
+
+allThePrimOpsArr :: SmallArray PrimOp
+{-# NOINLINE allThePrimOpsArr #-}
+allThePrimOpsArr = listToArray (maxPrimOpTag + 1) primOpTag id allThePrimOps
=====================================
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,186 @@
+{-# 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.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 <$> get bh)
+ <*> (Binary.decode <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ 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
@@ -1849,6 +1860,18 @@ instance Binary ByteString where
put_ bh f = putBS bh f
get bh = getBS bh
+instance Binary LBS.ByteString where
+ put_ bh lbs = do
+ put_ bh (fromIntegral (LBS.length lbs) :: Int)
+ let f bs acc =
+ ( BS.unsafeUseAsCStringLen bs $
+ \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l
+ )
+ *> acc
+ LBS.foldrChunks f (pure ()) lbs
+
+ get bh = LBS.fromStrict <$> get bh
+
instance Binary FastString where
put_ bh f =
case findUserDataWriter (Proxy :: Proxy FastString) bh of
@@ -2106,6 +2129,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 +2187,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 <$> get bh
+
+ put_ bh = put_ bh . 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
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -73,6 +73,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.OsPath
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b7dc69b5223abaf4860917472bba7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b7dc69b5223abaf4860917472bba7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0