[Git][ghc/ghc][wip/T23162-spj] 3 commits: Wibble HsExpr pretty printing
by Simon Peyton Jones (＠simonpj) 10 Aug '25
by Simon Peyton Jones (＠simonpj) 10 Aug '25
10 Aug '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
02c7e59f by Simon Peyton Jones at 2025-08-10T22:51:15+01:00
Wibble HsExpr pretty printing
- - - - -
ccc04b9a by Simon Peyton Jones at 2025-08-10T22:51:29+01:00
Whitespace only
- - - - -
e8a76095 by Simon Peyton Jones at 2025-08-10T23:22:27+01:00
Small improvements
- - - - -
4 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1144,6 +1144,7 @@ pprApp app
ppr_app fun args = hang (ppr_expr fun)
2 (pprDeeper (fsep (map pp args)))
+ -- pprDeeper: go deeper as we step inside an argument
pp (Left arg) = ppr arg
pp (Right arg) = text "@" <> ppr arg
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Core.TyCon
import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking
import GHC.Core.Coercion
import GHC.Core.Reduction
-import GHC.Core.FamInstEnv ( FamInstEnvs )
+import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core
import GHC.Types.Var
import GHC.Types.Var.Env
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -3,7 +3,6 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.FunDeps (
- unifyAndEmitFunDepWanteds,
tryDictFunDeps,
tryEqFunDeps
) where
@@ -35,20 +34,16 @@ import GHC.Core.Coercion.Axiom
import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam )
import GHC.Types.Name
-import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( filterOut )
-import GHC.Data.Bag
import GHC.Data.Pair
import qualified Data.Semigroup as S
-import Control.Monad
-
{- *********************************************************************
* *
* Functional dependencies for dictionaries
@@ -334,10 +329,14 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
do { inerts <- getInertCans
; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct)
- ; imp <- solveFunDeps $
- foldM do_interaction emptyCts $
- findDictsByClass (inert_dicts inerts) cls
- ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp)
+
+ ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
+ eqns = foldr ((++) . do_interaction) [] $
+ findDictsByClass (inert_dicts inerts) cls
+ ; imp <- solveFunDeps work_ev eqns
+
+ ; traceTcS "tryDictFunDepsLocal }" $
+ text "imp =" <+> ppr imp $$ text "eqns = " <+> ppr eqns
; if imp then startAgainWith (CDictCan dict_ct)
else continueWith () }
@@ -346,24 +345,17 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
work_loc = ctEvLoc work_ev
work_is_given = isGiven work_ev
- do_interaction :: Cts -> DictCt -> TcS Cts
- do_interaction new_eqs1 (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted
+ do_interaction :: DictCt -> [FunDepEqn (CtLoc, RewriterSet)]
+ do_interaction (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted
| work_is_given && isGiven inert_ev
-- Do not create FDs from Given/Given interactions
-- See Note [No Given/Given fundeps]
-- It is possible for work_ev to be Given when inert_ev is Wanted:
-- this can happen if a Given is kicked out by a unification
- = return new_eqs1
+ = []
| otherwise
- = do { new_eqs2 <- unifyFunDepWanteds_new work_ev $
- improveFromAnother (deriv_loc, inert_rewriters)
- inert_pred work_pred
-
- ; traceTcS "tryDictFunDepsLocal item" $
- vcat [ ppr work_ev, ppr new_eqs2 ]
-
- ; return (new_eqs1 `unionBags` new_eqs2) }
+ = improveFromAnother (deriv_loc, inert_rewriters) inert_pred work_pred
where
inert_pred = ctEvPred inert_ev
inert_loc = ctEvLoc inert_ev
@@ -387,8 +379,7 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
; traceTcS "tryDictFunDepsTop {" (ppr dict_ct)
; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
- ; imp <- solveFunDeps $
- unifyFunDepWanteds_new ev eqns
+ ; imp <- solveFunDeps ev eqns
; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp)
; if imp then startAgainWith (CDictCan dict_ct)
@@ -409,13 +400,6 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
new_orig = FunDepOrigin2 dict_pred dict_origin
inst_pred inst_loc
-solveFunDeps :: TcS Cts -> TcS Bool
-solveFunDeps generate_eqs
- = do { (unif_happened, _res) <- nestFunDepsTcS $
- do { eqs <- generate_eqs
- ; solveSimpleWanteds eqs }
- ; return unif_happened }
-
{- Note [No Given/Given fundeps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not create constraints from:
@@ -799,7 +783,7 @@ improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
= do { traceTcS "interactFunEq improvements: " $
vcat [ text "Eqns:" <+> ppr improvement_eqns
, text "Candidates:" <+> ppr funeqs_for_tc ]
- ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
+ ; solveFunDeps work_ev improvement_eqns }
where
work_loc = ctEvLoc work_ev
work_pred = ctEvPred work_ev
@@ -945,54 +929,21 @@ solving.
************************************************************************
-}
-unifyAndEmitFunDepWanteds :: CtEvidence -- The work item
- -> [FunDepEqn (CtLoc, RewriterSet)]
- -> TcS Bool -- True <=> some unification happened
-unifyAndEmitFunDepWanteds ev fd_eqns
+solveFunDeps :: CtEvidence -- The work item
+ -> [FunDepEqn (CtLoc, RewriterSet)]
+ -> TcS Bool
+-- See Note [FunDep and implicit parameter reactions]
+solveFunDeps work_ev fd_eqns
| null fd_eqns
- = return False
+ = return False -- common case noop
+
| otherwise
- = do { (fresh_tvs_s, new_eqs, unified_tvs) <- wrapUnifierX ev Nominal do_fundeps
-
- -- Figure out if a "real" unification happened: See Note [unifyFunDeps]
- ; let unif_happened = any is_old_tv unified_tvs
- fresh_tvs = mkVarSet (concat fresh_tvs_s)
- is_old_tv tv = not (tv `elemVarSet` fresh_tvs)
-
- ; -- Emit the deferred constraints
- -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
- --
- -- All the constraints in `cts` share the same rewriter set so,
- -- rather than looking at it one by one, we pass it to
- -- extendWorkListChildEqs; just a small optimisation.
- ; unless (isEmptyBag new_eqs) $
- updWorkListTcS (extendWorkListChildEqs ev new_eqs)
+ = do { (unif_happened, _res)
+ <- nestFunDepsTcS $
+ do { (_, eqs) <- unifyForAllBody work_ev Nominal do_fundeps
+ ; solveSimpleWanteds eqs }
; return unif_happened }
- where
- do_fundeps :: UnifyEnv -> TcM [[TcTyVar]]
- do_fundeps env = mapM (do_one env) fd_eqns
-
- do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM [TcTyVar]
- do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })
- = do { (fresh_tvs, eqs') <- instantiateFunDepEqn tvs (reverse eqs)
- -- (reverse eqs): See Note [Reverse order of fundep equations]
- ; uPairsTcM env_one eqs'
- ; return fresh_tvs }
- where
- env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters
- , u_loc = loc }
-
-unifyFunDepWanteds_new :: CtEvidence -- The work item
- -> [FunDepEqn (CtLoc, RewriterSet)]
- -> TcS Cts
--- See Note [FunDep and implicit parameter reactions]
-unifyFunDepWanteds_new _ []
- = return emptyCts -- common case noop
-
-unifyFunDepWanteds_new ev fd_eqns
- = do { (_, cts) <- unifyForAllBody ev Nominal do_fundeps
- ; return cts }
where
do_fundeps :: UnifyEnv -> TcM ()
do_fundeps env = mapM_ (do_one env) fd_eqns
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -522,23 +522,21 @@ pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of
_ -> runSDoc d ctx
--- | Truncate a list that is longer than the current depth.
+-- | Truncate a list that is longer than the default depth
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList f ds
| null ds = f []
| otherwise = SDoc work
where
- work ctx@SDC{sdocStyle=PprUser q depth c}
- | DefaultDepth <- depth
- = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c })
- | PartWay 0 <- depth
- = Pretty.text "..."
- | PartWay n <- depth
+ work ctx
= let
go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
- in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
+ go i (d:ds) | i >= default_depth = [text "...."]
+ | otherwise = d : go (i+1) ds
+ in runSDoc (f (go 0 ds)) ctx
+ where
+ default_depth = sdocDefaultDepth ctx
+
work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0240183357637242886b779215b04f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0240183357637242886b779215b04f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Oleg Grenrus pushed new branch wip/T26295 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26295
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: hadrian: enable terminfo if --with-curses-* flags are given
by Marge Bot (＠marge-bot) 10 Aug '25
by Marge Bot (＠marge-bot) 10 Aug '25
10 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
129c9fa1 by Sylvain Henry at 2025-08-10T16:40:21-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.
- - - - -
593cb612 by J. Ryan Stinnett at 2025-08-10T16:40:24-04:00
Fix extensions list in `DoAndIfThenElse` docs
- - - - -
464c54b8 by J. Ryan Stinnett at 2025-08-10T16:40:24-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
- - - - -
14 changed files:
- compiler/GHC/Cmm/CommonBlockElim.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
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/numeric/should_compile/T26229.hs
- testsuite/tests/numeric/should_compile/all.T
Changes:
=====================================
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
=====================================
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
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -80,6 +80,7 @@ stageBootPackages = return
stage0Packages :: Action [Package]
stage0Packages = do
cross <- flag CrossCompiling
+ haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ]
return $ [ cabalSyntax
, cabal
, compiler
@@ -116,8 +117,8 @@ stage0Packages = do
-- that confused Hadrian, so we must make those a stage0 package as well.
-- Once we drop `Win32`/`unix` it should be possible to drop those too.
]
- ++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ terminfo | not windowsHost, (not cross || haveCurses) ]
+ ++ [ timeout | windowsHost ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -24,6 +24,7 @@ packageArgs = do
-- immediately and may lead to cyclic dependencies.
-- See: https://gitlab.haskell.org/ghc/ghc/issues/16809.
cross = flag CrossCompiling
+ haveCurses = any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ]
-- Check if the bootstrap compiler has the same version as the one we
-- are building. This is used to build cross-compilers
@@ -85,7 +86,7 @@ packageArgs = do
-- backends at the moment, so we might as well disable it
-- for cross GHC.
[ andM [expr (ghcWithInterpreter stage), notCross] `cabalFlag` "internal-interpreter"
- , notM cross `cabalFlag` "terminfo"
+ , orM [ notM cross, haveCurses ] `cabalFlag` "terminfo"
, arg "-build-tool-depends"
, flag UseLibzstd `cabalFlag` "with-libzstd"
-- ROMES: While the boot compiler is not updated wrt -this-unit-id
@@ -120,7 +121,7 @@ packageArgs = do
-------------------------------- ghcPkg --------------------------------
, package ghcPkg ?
- builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo"
+ builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo"
-------------------------------- ghcBoot ------------------------------
, package ghcBoot ?
@@ -202,10 +203,10 @@ packageArgs = do
, package haskeline ?
builder (Cabal Flags) ? arg "-examples"
-- Don't depend upon terminfo when cross-compiling to avoid unnecessary
- -- dependencies.
- -- TODO: Perhaps the user should rather be responsible for this?
+ -- dependencies unless the user provided ncurses explicitly.
+ -- TODO: Perhaps the user should be able to explicitly enable/disable this.
, package haskeline ?
- builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo"
+ builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo"
-------------------------------- terminfo ------------------------------
, package terminfo ?
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
=====================================
@@ -26,10 +26,10 @@ import GHC.Internal.Base hiding (Type)
-- | The 'QuasiQuoter' type, a value @q@ of this type can be used
-- in the syntax @[q| ... string to parse ...|]@. In fact, for
-- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters
--- to be used in different splice contexts; if you are only interested
--- in defining a quasiquoter to be used for expressions, you would
--- define a 'QuasiQuoter' with only 'quoteExp', and leave the other
--- fields stubbed out with errors.
+-- to be used in different splice contexts. In the usual case of a
+-- @QuasiQuoter@ that is only intended to be used in certain splice
+-- contexts, the unused fields should just 'fail'. This is most easily
+-- accomplished using 'namedefaultQuasiQuoter' or 'defaultQuasiQuoter'.
data QuasiQuoter = QuasiQuoter {
-- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@
quoteExp :: String -> Q Exp,
=====================================
libraries/template-haskell/Language/Haskell/TH/Quote.hs
=====================================
@@ -16,6 +16,8 @@ that is up to you.
module Language.Haskell.TH.Quote
( QuasiQuoter(..)
, quoteFile
+ , namedDefaultQuasiQuoter
+ , defaultQuasiQuoter
-- * For backwards compatibility
,dataToQa, dataToExpQ, dataToPatQ
) where
@@ -39,3 +41,54 @@ quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec
get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
; addDependentFile file_name
; old_quoter file_cts }
+
+-- | A 'QuasiQuoter' that fails with a helpful error message in every
+-- context. It is intended to be modified to create a 'QuasiQuoter' that
+-- fails in all inappropriate contexts.
+--
+-- For example, you could write
+--
+-- @
+-- myPatQQ = (namedDefaultQuasiQuoter "myPatQQ")
+-- { quotePat = ... }
+-- @
+--
+-- If 'myPatQQ' is used in an expression context, the compiler will report
+-- that, naming 'myPatQQ'.
+--
+-- See also 'defaultQuasiQuoter', which does not name the 'QuasiQuoter' in
+-- the error message, and might therefore be more appropriate when
+-- the users of a particular 'QuasiQuoter' tend to define local \"synonyms\"
+-- for it.
+namedDefaultQuasiQuoter :: String -> QuasiQuoter
+namedDefaultQuasiQuoter name = QuasiQuoter
+ { quoteExp = f "use in expression contexts."
+ , quotePat = f "use in pattern contexts."
+ , quoteType = f "use in types."
+ , quoteDec = f "creating declarations."
+ }
+ where
+ f m _ = fail $ "The " ++ name ++ " quasiquoter is not for " ++ m
+
+-- | A 'QuasiQuoter' that fails with a helpful error message in every
+-- context. It is intended to be modified to create a 'QuasiQuoter' that
+-- fails in all inappropriate contexts.
+--
+-- For example, you could write
+--
+-- @
+-- myExpressionQQ = defaultQuasiQuoter
+-- { quoteExp = ... }
+-- @
+--
+-- See also 'namedDefaultQuasiQuoter', which names the 'QuasiQuoter' in the
+-- error messages.
+defaultQuasiQuoter :: QuasiQuoter
+defaultQuasiQuoter = QuasiQuoter
+ { quoteExp = f "use in expression contexts."
+ , quotePat = f "use in pattern contexts."
+ , quoteType = f "use in types."
+ , quoteDec = f "creating declarations."
+ }
+ where
+ f m _ = fail $ "This quasiquoter is not for " ++ m
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -1,5 +1,8 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.25.0.0
+ * Introduce `namedDefaultQuasiQuoter` and `defaultQuasiQuoter`, which fail with a helpful error when used in an inappropriate context.
+
## 2.24.0.0
* Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1370,6 +1370,8 @@ module Language.Haskell.TH.Quote where
dataToExpQ :: forall (m :: * -> *) a. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m GHC.Internal.TH.Syntax.Exp)) -> a -> m GHC.Internal.TH.Syntax.Exp
dataToPatQ :: forall (m :: * -> *) a. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m GHC.Internal.TH.Syntax.Pat)) -> a -> m GHC.Internal.TH.Syntax.Pat
dataToQa :: forall (m :: * -> *) a k q. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (GHC.Internal.TH.Syntax.Name -> k) -> (GHC.Internal.TH.Syntax.Lit -> m q) -> (k -> [m q] -> m q) -> (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m q)) -> a -> m q
+ defaultQuasiQuoter :: QuasiQuoter
+ namedDefaultQuasiQuoter :: GHC.Internal.Base.String -> QuasiQuoter
quoteFile :: QuasiQuoter -> QuasiQuoter
module Language.Haskell.TH.Syntax where
@@ -1720,8 +1722,8 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
@@ -1802,7 +1804,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1849,7 +1851,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a29fee78a3a81fe7b447ac12f8e66…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a29fee78a3a81fe7b447ac12f8e66…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] 58 commits: refactor: Modify Data.List.sortOn to use (>) instead of compare. (#26184)
by Apoorv Ingle (＠ani) 10 Aug '25
by Apoorv Ingle (＠ani) 10 Aug '25
10 Aug '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
1f9e4f54 by Stephen Morgan at 2025-08-03T15:14:08+10:00
refactor: Modify Data.List.sortOn to use (>) instead of compare. (#26184)
This lets a more efficient (>) operation be used if one exists.
This is technically a breaking change for malformed Ord instances, where
x > y is not equivalent to compare x y == GT.
Discussed by the CLC in issue #332: https://github.com/haskell/core-libraries-committee/issues/332
- - - - -
4f6bc9cf by fendor at 2025-08-04T17:50:06-04:00
Revert "base: Expose Backtraces constructor and fields"
This reverts commit 17db44c5b32fff82ea988fa4f1a233d1a27bdf57.
- - - - -
bcdec657 by Zubin Duggal at 2025-08-05T10:37:29+05:30
compiler: Export a version of `newNameCache` that is not prone to footguns.
`newNameCache` must be initialized with both a non-"reserved" unique tag, as well
as a list of known key names. Failing to do so results in hard to debug unique conflicts.
It is difficult for API users to tell which unique tags are safe to use. So instead of leaving
this up to the user to decide, we now export a version of `newNameCache` which uses a guaranteed
non-reserved unique tag. In fact, this is now the way the unique tag is initialized for all invocations
of the compiler.
The original version of `newNameCache` is now exported as `newNameCache'` for advanced users.
We also deprecate `initNameCache` as it is also prone to footguns and is completely subsumed in
functionality by `newNameCache` and `newNameCache'`.
Fixes #26135 and #26055
- - - - -
57d3b4a8 by Andrew Lelechenko at 2025-08-05T18:36:31-04:00
hadrian: bump Stackage snapshot to LTS 24.2 / GHC 9.10.2
In line with #25693 we should use GHC 9.10 as a boot compiler,
while Hadrian stack.yaml was stuck on GHC 9.6.
- - - - -
c2a78cea by Peng Fan at 2025-08-05T18:37:27-04:00
NCG/LA64: implement atomic write with finer-grained DBAR hints
Signed-off-by: Peng Fan <fanpeng(a)loongson.cn>
- - - - -
95231c8e by Teo Camarasu at 2025-08-06T08:35:58-04:00
CODEOWNERS: add CLC as codeowner of base
We also remove hvr, since I think he is no longer active
- - - - -
77df0ded by Andrew Lelechenko at 2025-08-06T08:36:39-04:00
Bump submodule text to 2.1.3
- - - - -
8af260d0 by Nikolaos Chatzikonstantinou at 2025-08-06T08:37:23-04:00
docs: fix internal import in getopt examples
This external-facing doc example shouldn't mention GHC internals when
using 'fromMaybe'.
- - - - -
69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00
README: Add note on ghc.nix
- - - - -
93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00
Link to the "Strict Bindings" docs from the linear types docs
Strict Bidings are relevant for the kinds of multiplicity annotations
linear lets support.
- - - - -
246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00
level imports: Check the level of exported identifiers
The level imports specification states that exported identifiers have to
be at level 0. This patch adds the requird level checks that all
explicitly mentioned identifiers occur at level 0.
For implicit export specifications (T(..) and module B), only level 0
identifiers are selected for re-export.
ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705
Fixes #26090
- - - - -
358bc4fc by fendor at 2025-08-07T06:59:12-04:00
Bump GHC on darwin CI to 9.10.1
- - - - -
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
695d6aa8 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
- Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed.
- Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx`
- `tcXExpr` is less hacky now
- do not look through HsExpansion applications
- kill OrigPat and remove HsThingRn From VAExpansion
- look through XExpr ExpandedThingRn while inferring type of head
- always set in generated code after stepping inside a ExpandedThingRn
- fixing record update error messages
- remove special case of tcbody from tcLambdaMatches
- wrap last stmt expansion in a HsPar so that the error messages are prettier
- remove special case of dsExpr for ExpandedThingTc
- make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn
- fixing error messages for rebindable
- - - - -
4f9b04d2 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs
- - - - -
f81ef1b9 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
move setQLInstLevel inside tcInstFun
- - - - -
c920bda7 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
ignore ds warnings originating from gen locations
- - - - -
50498466 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
filter expr stmts error msgs
- - - - -
6142b89e by Apoorv Ingle at 2025-08-10T11:47:10-05:00
exception for AppDo while making error ctxt
- - - - -
afcdcc39 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
moving around things for locations and error ctxts
- - - - -
e6d92598 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements
- - - - -
32d4aa90 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
accept test cases with changed error messages
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
bbbf717f by Apoorv Ingle at 2025-08-10T11:47:10-05:00
look through PopErrCtxt while splitting exprs in application chains
- - - - -
a9b52860 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
check the right origin for record selector incomplete warnings
- - - - -
4518fb1a by Apoorv Ingle at 2025-08-10T11:47:10-05:00
kill VAExpansion
- - - - -
ff7c53b1 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
pass CtOrigin to tcApp for instantiateSigma
- - - - -
9802dc8e by Apoorv Ingle at 2025-08-10T11:47:10-05:00
do not suppress pprArising
- - - - -
78ce8783 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
kill VACall
- - - - -
0b2ff42b by Apoorv Ingle at 2025-08-10T11:47:10-05:00
kill AppCtxt
- - - - -
e745d321 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
remove addHeadCtxt
- - - - -
e3055cd3 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
fix pprArising for MonadFailErrors
- - - - -
eb69d1b0 by Apoorv Ingle at 2025-08-10T11:47:10-05:00
rename ctxt to sloc
- - - - -
f40490bc by Apoorv Ingle at 2025-08-10T11:47:10-05:00
fix RepPolyDoBind error message herald
- - - - -
eb8f3bab by Apoorv Ingle at 2025-08-10T11:47:10-05:00
SrcCodeCtxt
more changes
- - - - -
eded19cd by Apoorv Ingle at 2025-08-10T11:47:11-05:00
make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin
- - - - -
7b483c64 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
make error messages for records saner
- - - - -
1a864e50 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
accept the right test output
- - - - -
f932a32e by Apoorv Ingle at 2025-08-10T11:47:11-05:00
make make sure to set inGenerated code for RecordUpdate checks
- - - - -
851d9c7f by Apoorv Ingle at 2025-08-10T11:47:11-05:00
rename HsThingRn to SrcCodeOrigin
- - - - -
38ae2380 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
minor lclenv getter setter changes
- - - - -
55435fcd by Apoorv Ingle at 2025-08-10T11:47:11-05:00
fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin
- - - - -
a9208611 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
undo test changes
- - - - -
b509a565 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
fix unused do binding warning error location
- - - - -
47a8e1b5 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
FRRRecordUpdate message change
- - - - -
972e0d7d by Apoorv Ingle at 2025-08-10T11:47:11-05:00
- kill tcl_in_gen_code
- It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt
- - - - -
f95855f3 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
kill ExpectedFunTyOrig
- - - - -
6fa77ee9 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
update argument position number of CtOrigin
- - - - -
35a55cc5 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
fix suggestion in error message for record field and modify herald everywhere
- - - - -
6dc8f1e0 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
new CtOrigin ExpectedTySyntax
- - - - -
8e15ec91 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
more changes to printing origin
- - - - -
edf7ce71 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
rep poly test case error messages
- - - - -
e44cd495 by Apoorv Ingle at 2025-08-10T11:47:11-05:00
OrigPat pprCtO says a do statement to mimic DoPatOrigin
- - - - -
88473c1a by Apoorv Ingle at 2025-08-10T11:47:11-05:00
remove location from OrigPat
- - - - -
111 changed files:
- .gitlab/darwin/toolchain.nix
- CODEOWNERS
- README.md
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Name/Reader.hs
- docs/users_guide/debug-info.rst
- docs/users_guide/exts/linear_types.rst
- docs/users_guide/exts/strict.rst
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- hadrian/stack.yaml
- hadrian/stack.yaml.lock
- libraries/base/changelog.md
- libraries/base/src/Control/Exception/Backtrace.hs
- libraries/base/src/Data/List/NonEmpty.hs
- libraries/base/src/System/Console/GetOpt.hs
- libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- libraries/text
- rts/IPE.c
- rts/ProfHeap.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/hiefile/should_run/TestUtils.hs
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- + testsuite/tests/splice-imports/DodgyLevelExport.hs
- + testsuite/tests/splice-imports/DodgyLevelExport.stderr
- + testsuite/tests/splice-imports/DodgyLevelExportA.hs
- + testsuite/tests/splice-imports/LevelImportExports.hs
- + testsuite/tests/splice-imports/LevelImportExports.stdout
- + testsuite/tests/splice-imports/LevelImportExportsA.hs
- testsuite/tests/splice-imports/Makefile
- + testsuite/tests/splice-imports/ModuleExport.hs
- + testsuite/tests/splice-imports/ModuleExport.stderr
- + testsuite/tests/splice-imports/ModuleExportA.hs
- + testsuite/tests/splice-imports/ModuleExportB.hs
- + testsuite/tests/splice-imports/T26090.hs
- + testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26090A.hs
- testsuite/tests/splice-imports/all.T
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/569ae5a51a74335fd659e9fe7d933f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/569ae5a51a74335fd659e9fe7d933f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
ed38d71b by Cheng Shao at 2025-08-10T14:06:23+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
b7ccecd3 by Cheng Shao at 2025-08-10T14:06:29+00:00
driver: test bytecode roundtrip serialization
- - - - -
11 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
-- | Breakpoint information constructed during ByteCode generation.
--
@@ -44,6 +45,7 @@ import GHC.HsToCore.Breakpoints
import GHC.Iface.Syntax
import GHC.Unit.Module (Module)
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Array
@@ -297,3 +299,26 @@ instance Outputable CgBreakInfo where
parens (ppr (cgb_vars info) <+>
ppr (cgb_resty info) <+>
ppr (cgb_tick_id info))
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+deriving via BreakpointId instance Binary InternalBreakLoc
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,187 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import Data.List (intersperse)
@@ -106,3 +107,13 @@ The breakpoint is in the function called "baz" that is declared in a `let`
or `where` clause of a declaration called "bar", which itself is declared
in a `let` or `where` clause of the top-level function called "foo".
-}
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -3,8 +3,12 @@ module GHC.Types.SptEntry
)
where
-import GHC.Types.Var ( Id )
+import GHC.Builtin.Types
+import GHC.Types.Id
+import GHC.Types.Name
import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Utils.Outputable
-- | An entry to be inserted into a module's static pointer table.
@@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+instance Binary SptEntry where
+ get bh = do
+ nm <- get bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ put_ bh (getName nm) *> put_ bh fp
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Types.Tickish (
GenTickish(..),
@@ -44,6 +45,7 @@ import GHC.Utils.Panic
import Language.Haskell.Syntax.Extension ( NoExtField )
import Data.Data
+import GHC.Utils.Binary
import GHC.Utils.Outputable (Outputable (ppr), text, (<+>))
{- *********************************************************************
@@ -202,6 +204,11 @@ instance NFData BreakpointId where
rnf BreakpointId{bi_tick_mod, bi_tick_index} =
rnf bi_tick_mod `seq` rnf bi_tick_index
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
--------------------------------------------------------------------------------
-- | A "counting tick" (where tickishCounts is True) is one that
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,8 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
+import GHCi.Message
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -140,8 +143,10 @@ import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
+import qualified Data.Binary as Binary
import Data.ByteString (ByteString, copy)
import Data.Coerce
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Short.Internal as SBS
@@ -929,6 +934,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2106,6 +2117,7 @@ instance Binary BinSrcSpan where
_ -> do s <- get bh
return $ BinSrcSpan (UnhelpfulSpan s)
+deriving via BinSrcSpan instance Binary SrcSpan
{-
Note [Source Location Wrappers]
@@ -2163,3 +2175,40 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fdebadb57507d452852e1c70fe9472…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fdebadb57507d452852e1c70fe9472…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
1362d5a8 by Cheng Shao at 2025-08-10T13:39:51+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
fdebadb5 by Cheng Shao at 2025-08-10T13:39:56+00:00
driver: test bytecode roundtrip serialization
- - - - -
10 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.HsToCore.Breakpoints
import GHC.Iface.Syntax
import GHC.Unit.Module (Module)
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Array
@@ -297,3 +298,11 @@ instance Outputable CgBreakInfo where
parens (ppr (cgb_vars info) <+>
ppr (cgb_resty info) <+>
ppr (cgb_tick_id info))
+
+deriving newtype instance Binary InternalBreakLoc
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,224 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -3,8 +3,12 @@ module GHC.Types.SptEntry
)
where
-import GHC.Types.Var ( Id )
+import GHC.Builtin.Types
+import GHC.Types.Id
+import GHC.Types.Name
import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Utils.Outputable
-- | An entry to be inserted into a module's static pointer table.
@@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+instance Binary SptEntry where
+ get bh = do
+ nm <- get bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ put_ bh (getName nm) *> put_ bh fp
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Types.Tickish (
GenTickish(..),
@@ -44,6 +45,7 @@ import GHC.Utils.Panic
import Language.Haskell.Syntax.Extension ( NoExtField )
import Data.Data
+import GHC.Utils.Binary
import GHC.Utils.Outputable (Outputable (ppr), text, (<+>))
{- *********************************************************************
@@ -202,6 +204,11 @@ instance NFData BreakpointId where
rnf BreakpointId{bi_tick_mod, bi_tick_index} =
rnf bi_tick_mod `seq` rnf bi_tick_index
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
--------------------------------------------------------------------------------
-- | A "counting tick" (where tickishCounts is True) is one that
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
d9a91519 by Cheng Shao at 2025-08-10T13:18:32+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
e1707f1c by Cheng Shao at 2025-08-10T13:18:37+00:00
driver: test bytecode roundtrip serialization
- - - - -
8 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,240 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+instance Binary InternalBreakLoc where
+ get bh = InternalBreakLoc <$> get bh
+
+ put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc
+
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -3,8 +3,12 @@ module GHC.Types.SptEntry
)
where
-import GHC.Types.Var ( Id )
+import GHC.Builtin.Types
+import GHC.Types.Id
+import GHC.Types.Name
import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Utils.Outputable
-- | An entry to be inserted into a module's static pointer table.
@@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+instance Binary SptEntry where
+ get bh = do
+ nm <- get bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ put_ bh (getName nm) *> put_ bh fp
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
bca57385 by Cheng Shao at 2025-08-10T13:06:05+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
c9eb4883 by Cheng Shao at 2025-08-10T13:06:11+00:00
driver: test bytecode roundtrip serialization
- - - - -
7 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,252 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.Builtin.Types
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SptEntry
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+instance Binary InternalBreakLoc where
+ get bh = InternalBreakLoc <$> get bh
+
+ put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc
+
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
+
+instance Binary SptEntry where
+ get bh = do
+ nm <- getViaSerializableName bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ putViaSerializableName bh (getName nm) *> put_ bh fp
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 16 commits: level imports: Check the level of exported identifiers
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00
level imports: Check the level of exported identifiers
The level imports specification states that exported identifiers have to
be at level 0. This patch adds the requird level checks that all
explicitly mentioned identifiers occur at level 0.
For implicit export specifications (T(..) and module B), only level 0
identifiers are selected for re-export.
ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705
Fixes #26090
- - - - -
358bc4fc by fendor at 2025-08-07T06:59:12-04:00
Bump GHC on darwin CI to 9.10.1
- - - - -
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
9bf81834 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00
cleanup: Move dehydrateCgBreakInfo to Stg2Bc
This no longer has anything to do with Core.
- - - - -
d6335551 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00
rts/Disassembler: Fix spacing of BRK_FUN
- - - - -
4dd9b18b by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Fix bciPtr in Step-out
We need to use `BCO_NEXT` to move bciPtr to ix=1, because ix=0 points to
the instruction itself!
I do not understand how this didn't crash before.
- - - - -
a75fafd4 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Allow BRK_FUNs to head case continuation BCOs
When we start executing a BCO, we may want to yield to the scheduler:
this may be triggered by a heap/stack check, context switch, or a
breakpoint. To yield, we need to put the stack in a state such that
when execution is resumed we are back to where we yielded from.
Previously, a BKR_FUN could only head a function BCO because we only
knew how to construct a valid stack for yielding from one -- simply add
`apply_interp_info` + the BCO to resume executing. This is valid because
the stack at the start of run_BCO is headed by that BCO's arguments.
However, in case continuation BCOs (as per Note [Case continuation BCOs]),
we couldn't easily reconstruct a valid stack that could be resumed
because we dropped too soon the stack frames regarding the value
returned (stg_ret) and received (stg_ctoi) by that continuation.
This is especially tricky because of the variable type and size return
frames (e.g. pointer ret_p/ctoi_R1p vs a tuple ret_t/ctoi_t2).
The trick to being able to yield from a BRK_FUN at the start of a case
cont BCO is to stop removing the ret frame headers eagerly and instead
keep them until the BCO starts executing. The new layout at the start of
a case cont. BCO is described by the new Note [Stack layout when entering run_BCO].
Now, we keep the ret_* and ctoi_* frames when entering run_BCO.
A BRK_FUN is then executed if found, and the stack is yielded as-is with
the preserved ret and ctoi frames.
Then, a case cont BCO's instructions always SLIDE off the headers of the
ret and ctoi frames, in StgToByteCode.doCase, turning a stack like
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| BCO |
+---------------+
| stg_ctoi_ret_ |
+---------------+
| retval |
+---------------+
| stg_ret_..... |
+---------------+
into
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| retval |
+---------------+
for the remainder of the BCO.
Moreover, this more uniform approach of keeping the ret and ctoi frames
means we need less ad-hoc logic concerning the variable size of
ret_tuple vs ret_p/np frames in the code generator and interpreter:
Always keep the return to cont. stack intact at the start of run_BCO,
and the statically generated instructions will take care of adjusting
it.
Unlocks BRK_FUNs at the start of case cont. BCOs which will enable a
better user-facing step-out (#26042) which is free of the bugs the
current BRK_ALTS implementation suffers from (namely, using BRK_FUN
rather than BRK_ALTS in a case cont. means we'll never accidentally end
up in a breakpoint "deeper" than the continuation, because we stop at
the case cont itself rather than on the first breakpoint we evaluate
after it).
- - - - -
f03ef9d3 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
BRK_FUN with InternalBreakLocs for code-generation time breakpoints
At the start of a case continuation BCO, place a BRK_FUN.
This BRK_FUN uses the new "internal breakpoint location" -- allowing us
to come up with a valid source location for this breakpoint that is not associated with a source-level tick.
For case continuation BCOs, we use the last tick seen before it as the
source location. The reasoning is described in Note [Debugger: Stepout internal break locs].
Note how T26042c, which was broken because it displayed the incorrect
behavior of the previous step out when we'd end up at a deeper level
than the one from which we initiated step-out, is now fixed.
As of this commit, BRK_ALTS is now dead code and is thus dropped.
Note [Debugger: Stepout internal break locs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Step-out tells the interpreter to run until the current function
returns to where it was called from, and stop there.
This is achieved by enabling the BRK_FUN found on the first RET_BCO
frame on the stack (See [Note Debugger: Step-out]).
Case continuation BCOs (which select an alternative branch) must
therefore be headed by a BRK_FUN. An example:
f x = case g x of <--- end up here
1 -> ...
2 -> ...
g y = ... <--- step out from here
- `g` will return a value to the case continuation BCO in `f`
- The case continuation BCO will receive the value returned from g
- Match on it and push the alternative continuation for that branch
- And then enter that alternative.
If we step-out of `g`, the first RET_BCO on the stack is the case
continuation of `f` -- execution should stop at its start, before
selecting an alternative. (One might ask, "why not enable the breakpoint
in the alternative instead?", because the alternative continuation is
only pushed to the stack *after* it is selected by the case cont. BCO)
However, the case cont. BCO is not associated with any source-level
tick, it is merely the glue code which selects alternatives which do
have source level ticks. Therefore, we have to come up at code
generation time with a breakpoint location ('InternalBreakLoc') to
display to the user when it is stopped there.
Our solution is to use the last tick seen just before reaching the case
continuation. This is robust because a case continuation will thus
always have a relevant breakpoint location:
- The source location will be the last source-relevant expression
executed before the continuation is pushed
- So the source location will point to the thing you've just stepped
out of
- Doing :step-local from there will put you on the selected
alternative (which at the source level may also be the e.g. next
line in a do-block)
Examples, using angle brackets (<<...>>) to denote the breakpoint span:
f x = case <<g x>> {- step in here -} of
1 -> ...
2 -> ...>
g y = <<...>> <--- step out from here
...
f x = <<case g x of <--- end up here, whole case highlighted
1 -> ...
2 -> ...>>
doing :step-local ...
f x = case g x of
1 -> <<...>> <--- stop in the alternative
2 -> ...
A second example based on T26042d2, where the source is a do-block IO
action, optimised to a chain of `case expressions`.
main = do
putStrLn "hello1"
<<f>> <--- step-in here
putStrLn "hello3"
putStrLn "hello4"
f = do
<<putStrLn "hello2.1">> <--- step-out from here
putStrLn "hello2.2"
...
main = do
putStrLn "hello1"
<<f>> <--- end up here again, the previously executed expression
putStrLn "hello3"
putStrLn "hello4"
doing step/step-local ...
main = do
putStrLn "hello1"
f
<<putStrLn "hello3">> <--- straight to the next line
putStrLn "hello4"
Finishes #26042
- - - - -
52ba24df by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Re-use the last BreakpointId whole in step-out
Previously, to come up with a location to stop at for `:stepout`, we
would store the location of the last BreakpointId surrounding the
continuation, as described by Note [Debugger: Stepout internal break locs].
However, re-using just the location from the last source breakpoint
isn't sufficient to provide the necessary information in the break
location. Specifically, it wouldn't bind any variables at that location.
Really, there is no reason not to re-use the last breakpoint wholesale,
and re-use all the information we had there. Step-out should behave just
as if we had stopped at the call, but s.t. continuing will not
re-execute the call.
This commit updates the CgBreakInfo to always store a BreakpointId, be
it the original one or the one we're emulating (for step-out).
It makes variable bindings on :stepout work
- - - - -
0fe77f20 by Cheng Shao at 2025-08-10T11:18:27+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
759209ae by Cheng Shao at 2025-08-10T11:18:27+00:00
driver: test bytecode roundtrip serialization
- - - - -
72 changed files:
- .gitlab/darwin/toolchain.nix
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/debug-info.rst
- ghc/GHCi/UI.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghci/GHCi/Run.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- rts/Disassembler.c
- rts/IPE.c
- rts/Interpreter.c
- rts/ProfHeap.c
- rts/Profiling.c
- rts/eventlog/EventLog.c
- rts/include/rts/Bytecodes.h
- rts/include/rts/IPE.h
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghci.debugger/scripts/T26042b.script
- testsuite/tests/ghci.debugger/scripts/T26042b.stdout
- testsuite/tests/ghci.debugger/scripts/T26042c.script
- testsuite/tests/ghci.debugger/scripts/T26042c.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042d2.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.script
- + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042e.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f.script
- testsuite/tests/ghci.debugger/scripts/T26042f1.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- + testsuite/tests/splice-imports/DodgyLevelExport.hs
- + testsuite/tests/splice-imports/DodgyLevelExport.stderr
- + testsuite/tests/splice-imports/DodgyLevelExportA.hs
- + testsuite/tests/splice-imports/LevelImportExports.hs
- + testsuite/tests/splice-imports/LevelImportExports.stdout
- + testsuite/tests/splice-imports/LevelImportExportsA.hs
- testsuite/tests/splice-imports/Makefile
- + testsuite/tests/splice-imports/ModuleExport.hs
- + testsuite/tests/splice-imports/ModuleExport.stderr
- + testsuite/tests/splice-imports/ModuleExportA.hs
- + testsuite/tests/splice-imports/ModuleExportB.hs
- + testsuite/tests/splice-imports/T26090.hs
- + testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26090A.hs
- testsuite/tests/splice-imports/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
10 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
611f3f3b by Simon Hengel at 2025-08-10T10:12:54+07:00
Remove JSON logging
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -368,7 +368,7 @@ msg msg = do
name_ppr_ctx <- getNamePprCtx
let m = case msg of
MCDump doc -> MCDump (dump_sty doc)
- MCDiagnostic span severity reason code doc -> UnsafeMCDiagnostic span severity reason code (err_sty doc)
+ UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic
MCOutput doc -> MCOutput (user_sty doc)
MCFatal doc -> MCFatal (user_sty doc)
MCInteractive doc -> MCInteractive (user_sty doc)
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -47,18 +47,15 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage logger msg_opts opts message = do
- decorated <- decorateDiagnostic logflags (messageClass doc) location
- if log_diags_as_json then do
- let
- rendered :: String
- rendered = renderWithContext (log_default_user_context logflags) decorated
-
- jsonMessage :: JsonDoc
- jsonMessage = jsonDiagnostic rendered message
-
- logJsonMsg logger (messageClass decorated) jsonMessage
- else do
- logMsg logger (messageClass decorated)
+ decorated <- decorateDiagnostic logflags location severity reason code doc
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) decorated
+
+ jsonMessage :: JsonDoc
+ jsonMessage = jsonDiagnostic rendered message
+
+ logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage
where
logflags :: LogFlags
logflags = logFlags logger
@@ -66,9 +63,6 @@ printMessage logger msg_opts opts message = do
doc :: SDoc
doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
- messageClass :: SDoc -> Message
- messageClass = UnsafeMCDiagnostic location severity (errMsgReason message) (diagnosticCode diagnostic)
-
style :: PprStyle
style = mkErrStyle (errMsgContext message)
@@ -84,6 +78,12 @@ printMessage logger msg_opts opts message = do
severity :: Severity
severity = errMsgSeverity message
+ reason :: ResolvedDiagnosticReason
+ reason = errMsgReason message
+
+ code :: Maybe DiagnosticCode
+ code = diagnosticCode diagnostic
+
messageWithHints :: a -> SDoc
messageWithHints e =
let main_msg = formatBulleted $ diagnosticMessage msg_opts e
@@ -93,21 +93,18 @@ printMessage logger msg_opts opts message = do
hs -> main_msg $$ hang (text "Suggested fixes:") 2
(formatBulleted $ mkDecorated . map ppr $ hs)
- log_diags_as_json :: Bool
- log_diags_as_json = log_diagnostics_as_json (logFlags logger)
-
-decorateDiagnostic :: LogFlags -> Message -> SrcSpan -> IO SDoc
-decorateDiagnostic logflags msg srcSpan = addCaret
+decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc
+decorateDiagnostic logflags span severity reason code doc = addCaret
where
-- Pretty print the warning flag, if any (#10752)
message :: SDoc
- message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg srcSpan
+ message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc
addCaret :: IO SDoc
addCaret = do
caretDiagnostic <-
if log_show_caret logflags
- then getCaretDiagnostic msg srcSpan
+ then getCaretDiagnostic severity span
else pure empty
return $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1445,9 +1445,9 @@ withDeferredDiagnostics f = do
let deferDiagnostics _dflags !msg = do
let action = logMsg logger msg
case msg of
- MCDiagnostic _ SevWarning _reason _code _
+ MCDiagnostic _ SevWarning _reason _code
-> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())
- MCDiagnostic _ SevError _reason _code _
+ MCDiagnostic _ SevError _reason _code
-> atomicModifyIORef' errors $ \(!i) -> (action: i, ())
MCFatal _
-> atomicModifyIORef' fatals $ \(!i) -> (action: i, ())
=====================================
compiler/GHC/Driver/Monad.hs
=====================================
@@ -23,8 +23,6 @@ module GHC.Driver.Monad (
modifyLogger,
pushLogHookM,
popLogHookM,
- pushJsonLogHookM,
- popJsonLogHookM,
putLogMsgM,
putMsgM,
withTimingM,
@@ -122,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook
popLogHookM :: GhcMonad m => m ()
popLogHookM = modifyLogger popLogHook
-pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()
-pushJsonLogHookM = modifyLogger . pushJsonLogHook
-
-popJsonLogHookM :: GhcMonad m => m ()
-popJsonLogHookM = modifyLogger popJsonLogHook
-
-- | Put a log message
putMsgM :: GhcMonad m => SDoc -> m ()
putMsgM doc = do
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -70,7 +70,6 @@ module GHC.Types.Error
, mapDecoratedSDoc
, pprMessageBag
- , mkLocMessageWarningGroups
, formatLocMessage
, formatFatalLocMessage
, formatDiagnostic
@@ -493,7 +492,7 @@ data Message
-- ^ Log messages intended for end users.
-- No file\/line\/column stuff.
- | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc
+ | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc
-- ^ Diagnostics from the compiler. This constructor is very powerful as
-- it allows the construction of a 'Message' with a completely
-- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
@@ -509,8 +508,8 @@ data Message
-- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].
{-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-}
-pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> Message
-pattern MCDiagnostic span severity reason code doc <- UnsafeMCDiagnostic span severity reason code doc
+pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message
+pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json
{-
Note [Suppressing Messages]
@@ -635,25 +634,9 @@ showMsgEnvelope err =
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
--- | Make an error message with location info, specifying whether to show
--- warning groups (if applicable).
-mkLocMessageWarningGroups
- :: Bool -- ^ Print warning groups (if applicable)?
- -> Message -- ^ message
- -> SrcSpan -- ^ location
- -> SDoc
-mkLocMessageWarningGroups show_warn_groups msg locn
- = case msg of
- MCDiagnostic span severity reason code doc -> formatDiagnostic show_warn_groups span severity reason code doc
- MCFatal doc -> formatFatalLocMessage locn doc
- MCOutput doc -> formatLocMessage locn doc
- MCInteractive doc -> formatLocMessage locn doc
- MCDump doc -> formatLocMessage locn doc
- MCInfo doc -> formatLocMessage locn doc
-
formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc
formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme ->
- let msg_title = coloured (fatalColour col_scheme) $ text "fatal"
+ let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal"
in formatLocMessageWarningGroups locn msg_title empty empty msg
formatLocMessage :: SrcSpan -> SDoc -> SDoc
@@ -770,23 +753,15 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
in coloured (Col.sMessage col_scheme)
$ hang (coloured (Col.sHeader col_scheme) header) 4 msg
-getMessageClassColour :: Message -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic _span severity _reason _code _) = getSeverityColour severity
-getMessageClassColour (MCFatal _) = fatalColour
-getMessageClassColour _ = const mempty
-
-fatalColour :: Col.Scheme -> Col.PprColour
-fatalColour = Col.sFatal
-
getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour severity = case severity of
SevError -> Col.sError
SevWarning -> Col.sWarning
SevIgnore -> const mempty
-getCaretDiagnostic :: Message -> SrcSpan -> IO SDoc
+getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
-getCaretDiagnostic msg (RealSrcSpan span _) =
+getCaretDiagnostic severity (RealSrcSpan span _) =
caretDiagnostic <$> getSrcLine (srcSpanFile span) row
where
getSrcLine fn i =
@@ -819,7 +794,7 @@ getCaretDiagnostic msg (RealSrcSpan span _) =
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
sdocOption sdocColScheme$ \col_scheme ->
- let sevColour = getMessageClassColour msg col_scheme
+ let sevColour = getSeverityColour severity col_scheme
marginColour = Col.sMargin col_scheme
in
coloured marginColour (text marginSpace) <>
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -24,7 +24,6 @@ module GHC.Utils.Logger
-- * Logger setup
, initLogger
, LogAction
- , LogJsonAction
, DumpAction
, TraceAction
, DumpFormat (..)
@@ -32,8 +31,6 @@ module GHC.Utils.Logger
-- ** Hooks
, popLogHook
, pushLogHook
- , popJsonLogHook
- , pushJsonLogHook
, popDumpHook
, pushDumpHook
, popTraceHook
@@ -55,11 +52,9 @@ module GHC.Utils.Logger
, putLogMsg
, defaultLogAction
, defaultLogActionWithHandles
- , defaultLogJsonAction
, defaultLogActionHPrintDoc
, defaultLogActionHPutStrDoc
, logMsg
- , logJsonMsg
, logDumpMsg
-- * Dumping
@@ -86,8 +81,8 @@ import GHC.Types.Error
import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Outputable
-import GHC.Utils.Json
import GHC.Utils.Panic
+import GHC.Utils.Json (renderJSON)
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
@@ -181,11 +176,6 @@ type LogAction = LogFlags
-> Message
-> IO ()
-type LogJsonAction = LogFlags
- -> Message
- -> JsonDoc
- -> IO ()
-
type DumpAction = LogFlags
-> PprStyle
-> DumpFlag
@@ -223,9 +213,6 @@ data Logger = Logger
{ log_hook :: [LogAction -> LogAction]
-- ^ Log hooks stack
- , json_log_hook :: [LogJsonAction -> LogJsonAction]
- -- ^ Json log hooks stack
-
, dump_hook :: [DumpAction -> DumpAction]
-- ^ Dump hooks stack
@@ -261,7 +248,6 @@ initLogger = do
dumps <- newMVar Map.empty
return $ Logger
{ log_hook = []
- , json_log_hook = []
, dump_hook = []
, trace_hook = []
, generated_dumps = dumps
@@ -273,10 +259,6 @@ initLogger = do
putLogMsg :: Logger -> LogAction
putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
--- | Log a JsonDoc
-putJsonLogMsg :: Logger -> LogJsonAction
-putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger)
-
-- | Dump something
putDumpFile :: Logger -> DumpAction
putDumpFile logger =
@@ -301,15 +283,6 @@ popLogHook logger = case log_hook logger of
[] -> panic "popLogHook: empty hook stack"
_:hs -> logger { log_hook = hs }
--- | Push a json log hook
-pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
-pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger }
-
-popJsonLogHook :: Logger -> Logger
-popJsonLogHook logger = case json_log_hook logger of
- [] -> panic "popJsonLogHook: empty hook stack"
- _:hs -> logger { json_log_hook = hs}
-
-- | Push a dump hook
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
@@ -353,22 +326,6 @@ makeThreadSafe logger = do
$ pushTraceHook trc
$ logger
-defaultLogJsonAction :: LogJsonAction
-defaultLogJsonAction logflags msg_class jsdoc =
- case msg_class of
- MCOutput _ -> printOut msg
- MCDump _ -> printOut (msg $$ blankLine)
- MCInteractive _ -> putStrSDoc msg
- MCInfo _ -> printErrs msg
- MCFatal _ -> printErrs msg
- MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message
- MCDiagnostic _span _sev _rea _code _ -> printErrs msg
- where
- printOut = defaultLogActionHPrintDoc logflags False stdout
- printErrs = defaultLogActionHPrintDoc logflags False stderr
- putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
- msg = renderJSON jsdoc
-
-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
@@ -386,8 +343,12 @@ defaultLogActionWithHandles out err logflags message
MCInteractive msg -> putStrSDoc msg
MCInfo msg -> printErrs msg
MCFatal msg -> printErrs msg
- MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message
- MCDiagnostic _span _sev _rea _code msg -> printErrs msg
+ MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message
+ UnsafeMCDiagnostic _span _severity _reason _code doc json -> do
+ if log_diagnostics_as_json logflags then do
+ printErrs (renderJSON json)
+ else do
+ printErrs doc
where
printOut = defaultLogActionHPrintDoc logflags False out
printErrs = defaultLogActionHPrintDoc logflags False err
@@ -534,9 +495,6 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> Message -> IO ()
logMsg logger = putLogMsg logger (logFlags logger)
-logJsonMsg :: Logger -> Message -> JsonDoc -> IO ()
-logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile logger = putDumpFile logger (logFlags logger)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -836,7 +836,7 @@ ghciLogAction lastErrLocations old_log_action
dflags msg = do
old_log_action dflags msg
case msg of
- MCDiagnostic srcSpan SevError _reason _code _ -> case srcSpan of
+ MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of
RealSrcSpan rsp _ -> modifyIORef lastErrLocations
(++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
_ -> return ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0