- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Change representation of floating point literals
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7d4ef162 by Matthew Craven at 2026-03-20T12:22:47-04:00 Change representation of floating point literals This commit changes the representation of floating point literals throughough the compiler, in particular in Core and Cmm. The Rational type is deficient for this purpose, dealing poorly with NaN, +/-Infinity, and negative zero. Instead, the new module GHC.Types.Literal.Floating uses the host Float/Double type to represent NaNs, infinities and negative zero. It also contains a Rational constructor, for the benefit of -fexcess-precision. Other changes: - Remove Note [negative zero] and related code This also removes the restrictions on constant-folding of division by zero, and should make any problems with NaN/Infinity more obvious. - Use -0.0 as the additive identity for Core constant folding rules for floating-point addition, fixing #21227. - Manual worker-wrapper for GHC.Float.rationalToDouble. This is intended to prevent the compiler's WW on this function from interfering with constant-folding. This change means that we now avoid allocating a box for the result of a 'realToFrac' call in T10359. - Combine floatDecodeOp and doubleDecodeOp. This change also fixes a bug in doubleDecodeOp wherein it would incorrectly produce an Int# instead of an Int64# literal for the mantissa component with 64-bit targets. - Use Float/Double for assembly immediates, and update the X86 and PowerPC backends to properly handle special values such as NaN and infinity. - Allow 'rational_to' to handle zero denominators, fixing a TODO in GHC.Core.Opt.ConstantFold. Fixes #8364 #9811 #18897 #21227 Progress towards #26919 Metric Decrease: T10359 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> ------------------------- Metric Decrease: T1969 T5321FD ------------------------- - - - - - 50 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Type.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/AArch64/Regs.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/CmmToAsm/LA64/Regs.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/PPC/Regs.hs - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToAsm/X86/Regs.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Literal.hs - compiler/GHC/Types/Literal.hs - + compiler/GHC/Types/Literal/Floating.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - libraries/ghc-internal/src/GHC/Internal/Float.hs - + testsuite/tests/codeGen/should_run/T21227.hs - + testsuite/tests/codeGen/should_run/T21227.stdout - + testsuite/tests/codeGen/should_run/T9811.hs - + testsuite/tests/codeGen/should_run/T9811.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/numeric/should_run/T7014.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d4ef162a3b39df8a7b8d96e4031e82… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d4ef162a3b39df8a7b8d96e4031e82… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: opportunistically grow the MutableByteArray# in-place in resizeMutableByteArray#
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 309d7e87 by Cheng Shao at 2026-03-20T12:21:53-04:00 rts: opportunistically grow the MutableByteArray# in-place in resizeMutableByteArray# Following !15234, this patch improves `resizeMutableByteArray#` memory efficiency by growing the `MutableByteArray#` in-place if possible, addressing an old todo comment here. Also adds a new test case `resizeMutableByteArrayInPlace` that stresses this behavior. - - - - - 3 changed files: - rts/PrimOps.cmm - testsuite/tests/rts/all.T - + testsuite/tests/rts/resizeMutableByteArrayInPlace.hs Changes: ===================================== rts/PrimOps.cmm ===================================== @@ -200,6 +200,26 @@ stg_isMutableByteArrayWeaklyPinnedzh ( gcptr mba ) * used to as the LDV profiler will essentially ignore arrays anyways. */ +/* Note [Resizing arrays in-place] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * We try to shrink or grow bd->free when resizing a MutableByteArray in-place, + * to reclaim or use slop space at the end of the current block and avoid + * unnecessary fragmentation/allocation. + * + * But we must guarantee that: + * + * 1. mba is already at the end of current block (check bd->free). + * Otherwise we can't move closures that come after it anyway. + * 2. It's a nursery block that belongs to the current Capability, + * so check rCurrentAlloc (used by allocateMightFail) or + * pinned_object_block (used by allocatePinned). There's also no + * point if it's an older generation block, the mutator won't + * allocate into those blocks anyway. + * + * If check fails, fall back to the conservative code path: just zero the slop + * and return when shrinking, or allocate a new array when growing. + */ + // shrink size of MutableByteArray in-place stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) // MutableByteArray# s -> Int# -> State# s -> State# s @@ -212,20 +232,7 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) old_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(old_size); new_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(new_size); - // Try to shrink bd->free as well, to reclaim slop space at the end - // of current block and avoid unnecessary fragmentation. But we - // must guarantee that: - // - // 1. mba is already at the end of current block (check bd->free). - // Otherwise we can't move closures that come after it anyway. - // 2. It's a nursery block that belongs to the current Capability, - // so check rCurrentAlloc (used by allocateMightFail) or - // pinned_object_block (used by allocatePinned). There's also no - // point if it's an older generation block, the mutator won't - // allocate into those blocks anyway. - // - // If check fails, fall back to the conservative code path: just - // zero the slop and return. + // See Note [Resizing arrays in-place] bd = Bdescr(mba); if (bdescr_free(bd) != mba + WDS(old_wds) || (bd != StgRegTable_rCurrentAlloc(BaseReg) && bd != Capability_pinned_object_block(MyCapability()))) { @@ -258,20 +265,33 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size ) // MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) { + W_ old_size, old_wds, new_wds, new_free; + W_ bd; + ASSERT(new_size `ge` 0); - if (new_size <= StgArrBytes_bytes(mba)) { + old_size = StgArrBytes_bytes(mba); + if (new_size <= old_size) { call stg_shrinkMutableByteArrayzh(mba, new_size); return (mba); + } + + bd = Bdescr(mba); + old_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(old_size); + new_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(new_size); + new_free = mba + WDS(new_wds); + + // See Note [Resizing arrays in-place] + // we also need to check that we don't grow past the end of current block. + if (bdescr_free(bd) == mba + WDS(old_wds) && + (bd == StgRegTable_rCurrentAlloc(BaseReg) || bd == Capability_pinned_object_block(MyCapability())) && + new_free <= bdescr_start(bd) + (TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE)) { + bdescr_free(bd) = new_free; + StgArrBytes_bytes(mba) = new_size; + return (mba); } else { (P_ new_mba) = call stg_newByteArrayzh(new_size); - // maybe at some point in the future we may be able to grow the - // MBA in-place w/o copying if we know the space after the - // current MBA is still available, as often we want to grow the - // MBA shortly after we allocated the original MBA. So maybe no - // further allocations have occurred by then. - // copy over old content prim %memcpy(BYTE_ARR_CTS(new_mba), BYTE_ARR_CTS(mba), StgArrBytes_bytes(mba), SIZEOF_W); ===================================== testsuite/tests/rts/all.T ===================================== @@ -669,3 +669,5 @@ test('TimeoutQueue', test('ClosureTable', [req_c, only_ways(['normal', 'debug']), extra_files(['ClosureTable_c.c'])], compile_and_run, ['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include']) + +test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, ['']) ===================================== testsuite/tests/rts/resizeMutableByteArrayInPlace.hs ===================================== @@ -0,0 +1,24 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +import Control.Monad +import GHC.Exts +import GHC.IO + +-- Given newByteArray#/newPinnedByteArray#, iterate given number of +-- rounds: first allocate a MutableByteArray# using the first size, +-- then resize to the new size, then resize back +{-# INLINE testResize #-} +testResize :: (Int# -> State# RealWorld -> (# State# RealWorld, MutableByteArray# RealWorld #)) -> Int -> Int -> Int -> IO () +testResize alloc# rounds (I# sz0#) (I# sz1#) = + replicateM_ rounds $ IO $ \s0 -> case alloc# sz0# s0 of + (# s1, mba0# #) -> case resizeMutableByteArray# mba0# sz1# s1 of + (# s2, mba1# #) -> case resizeMutableByteArray# mba1# sz0# s2 of + (# s3, _ #) -> (# s3, () #) + +main :: IO () +main = do + testResize newByteArray# 100000 8 64 + testResize newByteArray# 100000 64 8 + testResize newPinnedByteArray# 100000 8 64 + testResize newPinnedByteArray# 100000 64 8 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309d7e87fe3e4653cf1be3cab6c987f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309d7e87fe3e4653cf1be3cab6c987f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Improve incomplete record selector warnings
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 52c3e6ba by sheaf at 2026-03-20T12:21:09-04:00 Improve incomplete record selector warnings This commit stops GHC from emitting spurious incomplete record selector warnings for bare selectors/projections such as .fld There are two places we currently emit incomplete record selector warnings: 1. In the desugarer, when we see a record selector or an occurrence of 'getField'. Here, we can use pattern matching information to ensure we don't give false positives. 2. In the typechecker, which might sometimes give false positives but can emit warnings in cases that the pattern match checker would otherwise miss. This is explained in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc. Now, we obviously don't want to emit the same error twice, and generally we prefer (1), as those messages contain fewer false positives. So we suppress (2) when we are sure we are going to emit (1); the logic for doing so is in GHC.Tc.Instance.Class.warnIncompleteRecSel, and works by looking at the CtOrigin. Now, the issue was that this logic handled explicit record selectors as well as overloaded record field selectors such as "x.r" (which turns into a simple GetFieldOrigin CtOrigin), but it didn't properly handle record projectors like ".fld" or ".fld1.fld2" (which result in other CtOrigins such as 'RecordFieldProjectionOrigin'). To solve this problem, we re-use the 'isHasFieldOrigin' introduced in fbdc623a (slightly adjusted). On the way, we also had to update the desugarer with special handling for the 'ExpandedThingTc' case in 'ds_app', to make sure that 'ds_app_var' sees all the type arguments to 'getField' in order for it to indeed emit warnings like in (1). Fixes #26686 - - - - - 8 changed files: - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Origin.hs - + testsuite/tests/overloadedrecflds/should_compile/T26686.hs - + testsuite/tests/overloadedrecflds/should_compile/T26686.stderr - testsuite/tests/overloadedrecflds/should_compile/all.T Changes: ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -721,6 +721,15 @@ ds_app (XExpr (ConLikeTc con)) _hs_args core_args ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args = ds_app_rec_sel sel_id sel_id core_args +ds_app (XExpr (ExpandedThingTc _orig e)) hs_args core_args + = ds_app e hs_args core_args + -- NB: this is important for the 'getField' case of 'ds_app_var', which needs + -- to see all type arguments to 'getField' at once, while for record field + -- projections such as (.fld) we may get: + -- + -- XExpr (ExpandedThingTc (.fld) (getField @Symbol @LiftedRep @LiftedRep "fld")) + -- `HsAppType` rec_ty `HsAppType` fld + ds_app (HsVar _ lfun) hs_args core_args = ds_app_var lfun hs_args core_args @@ -736,8 +745,10 @@ ds_app_var (L loc fun_id) hs_args core_args ----------------------- -- Deal with getField applications. General form: -- getField - -- @GHC.Types.Symbol {k} - -- @"sel" x_ty + -- @Symbol {k} + -- @LiftedRep {r_rep} + -- @LiftedRep {a_rep} + -- @"sel" fld -- @T r_ty -- @Int a_ty -- ($dHasField :: HasField "sel" T Int) dict ===================================== compiler/GHC/HsToCore/Pmc.hs ===================================== @@ -375,6 +375,10 @@ Finally, there are two more items addressing -XOverloadedRecordDot: the (IRS6) warning in the typechecker for a `HasField` constraint that arises from a record-dot HsGetField occurrence. Happily, this is easy to do by looking at its `CtOrigin`. Tested in T24891. + + The same applies for record field projection operators such as (.fld) and + (.fld1.fld2), which have different 'CtOrigin's. The 'isHasFieldOrigin' + function catches those as well. Tested in T26686. -} pmcRecSel :: Id -- ^ Id of the selector ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -97,6 +97,7 @@ import Data.Ord ( comparing ) import Data.Either ( partitionEithers ) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.Semigroup as Semi {- ************************************************************************ @@ -2714,15 +2715,34 @@ hasFieldInfo_maybe rdr_env fam_inst_envs item -- (HF2e) It's a custom HasField constraint, not the one from GHC.Records. | Just (tc, _) <- splitTyConApp_maybe (errorItemPred item) - , getOccString tc == "HasField" - , isHasFieldOrigin (errorItemOrigin item) - = return $ Just $ CustomHasField tc + = do { rebindable_syntax <- xoptM LangExt.RebindableSyntax + ; return $ + if want_custom_hasfield_msg tc rebindable_syntax + then Just $ CustomHasField tc + else Nothing + } | otherwise = return Nothing where + orig = errorItemOrigin item + + want_custom_hasfield_msg tc rebindable_syntax + | getOccString tc == "HasField" + = Semi.getAny $ foldMapCtOrigin (Semi.Any . is_has_field) orig + | otherwise + = False + where + -- Handle custom 'getField'/'setField' with RebindableSyntax. + is_has_field (OccurrenceOf n) + | rebindable_syntax + , getOccString n `elem` ["getField", "setField"] + = True + is_has_field o + = isHasFieldOrigin o + get_parent_nm :: Name -> TcM (Maybe (Either PatSyn TyCon)) get_parent_nm nm = do { fld_id <- tcLookupId nm @@ -2762,22 +2782,6 @@ hasField_maybe pred = -- NB: we deliberately don't handle rebound 'HasField' (with -XRebindableSyntax), -- as GHC only has built-in instances for the built-in 'HasField' class. --- | Does this constraint arise from GHC internal mechanisms that desugar to --- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)? --- --- Just used heuristically to decide whether to print an informative message to --- the user (see (H2e) in Note [Error messages for unsolved HasField constraints]). -isHasFieldOrigin :: CtOrigin -> Bool -isHasFieldOrigin = \case - OccurrenceOf n -> - -- A heuristic... - getOccString n `elem` ["getField", "setField"] - OccurrenceOfRecSel {} -> True - RecordUpdOrigin {} -> True - RecordFieldProjectionOrigin {} -> True - GetFieldOrigin {} -> True - _ -> False - ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, isHasFieldOrigin ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1275,8 +1275,8 @@ warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM () -- Warn about incomplete record selectors -- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc warnIncompleteRecSel dflags sel_id ct_loc - | not (isGetFieldOrigin (ctLocOrigin ct_loc)) - -- isGetFieldOrigin: see (IRS7) in + | not $ isHasFieldOrigin (ctLocOrigin ct_loc) + -- isHasFieldOrigin: see (IRS7) in -- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc , RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id , not (null fallible_cons) @@ -1288,11 +1288,6 @@ warnIncompleteRecSel dflags sel_id ct_loc where maxCons = maxUncoveredPatterns dflags - -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, - -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (GetFieldOrigin {}) = True - isGetFieldOrigin _ = False - lookupHasFieldLabel :: FamInstEnvs -> GlobalRdrEnv -> [Type] -> Maybe ( Name -- Name of the record selector ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -16,7 +16,8 @@ module GHC.Tc.Types.Origin ( CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, pprCtOriginBriefly, isGivenOrigin, - defaultReprEqOrigins, isWantedSuperclassOrigin, + foldMapCtOrigin, + defaultReprEqOrigins, isWantedSuperclassOrigin, isHasFieldOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), HsImplicitLiftSplice(..), StandaloneDeriv, @@ -52,6 +53,8 @@ import GHC.Tc.Utils.TcType import GHC.Hs +import GHC.Builtin.Names (getFieldName) + import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon @@ -79,6 +82,8 @@ import GHC.Types.Unique.Supply import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) +import qualified Data.Semigroup as Semi +import GHC.Generics {- ********************************************************************* * * @@ -993,6 +998,95 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear") pprNonLinearPatternReason OtherPatternReason = empty + +{- ********************************************************************* +* * + Recursing through CtOrigin +* * +********************************************************************* -} + +-- | Fold over a 'CtOrigin', looking through all recursive +-- occurrences of 'CtOrigin' within 'CtOrigin'. +foldMapCtOrigin :: forall m. Semigroup m => (CtOrigin -> m) -> CtOrigin -> m +foldMapCtOrigin f = go + where + go :: CtOrigin -> m + go orig = + case orig of + KindEqOrigin _ _ o _ -> recur o + CycleBreakerOrigin o -> recur o + WantedSuperclassOrigin _ o -> recur o + DefaultReprEqOrigin _ _ o -> recur o + ScOrigin cls_or_qc _sc_flag -> + case cls_or_qc of + IsQC _ o -> recur o + IsClsInst -> f orig + + -- Explicit pattern match on remaining constructors, in order to get + -- better pattern-match warnings when constructors are changed or + -- added/removed. This isn't entirely fool-proof, as someone may still + -- change the type of one of the fields and hide a 'CtOrigin' inside. + -- + -- This approach was chosen instead of using 'syb'/'GHC.Generics', + -- because those would require deriving 'Data.Data'/'Generic' on + -- a huge number of datatypes. + GivenOrigin {} -> f orig + GivenSCOrigin {} -> f orig + OccurrenceOf {} -> f orig + OccurrenceOfRecSel {} -> f orig + AppOrigin {} -> f orig + SpecPragOrigin {} -> f orig + TypeEqOrigin {}-> f orig + IPOccOrigin {} -> f orig + OverLabelOrigin {} -> f orig + LiteralOrigin {} -> f orig + QualLiteralOrigin {} -> f orig + NegateOrigin {} -> f orig + ArithSeqOrigin {} -> f orig + AssocFamPatOrigin {} -> f orig + SectionOrigin {} -> f orig + GetFieldOrigin {} -> f orig + RecordFieldProjectionOrigin {} -> f orig + TupleOrigin {} -> f orig + ExprSigOrigin {} -> f orig + PatSigOrigin {} -> f orig + PatOrigin {} -> f orig + ProvCtxtOrigin {} -> f orig + RecordUpdOrigin {} -> f orig + ViewPatOrigin {} -> f orig + DerivOrigin {} -> f orig + DerivOriginDC {} -> f orig + DerivOriginCoerce {} -> f orig + DefaultOrigin {} -> f orig + DoOrigin {} -> f orig + DoPatOrigin {} -> f orig + MCompOrigin {} -> f orig + MCompPatOrigin {} -> f orig + ProcOrigin {} -> f orig + ArrowCmdOrigin {} -> f orig + AnnOrigin {} -> f orig + FunDepOrigin {} -> f orig + ExprHoleOrigin {} -> f orig + TypeHoleOrigin {} -> f orig + PatCheckOrigin {} -> f orig + ListOrigin {} -> f orig + IfThenElseOrigin {} -> f orig + BracketOrigin {} -> f orig + StaticOrigin {} -> f orig + ImpedanceMatching {} -> f orig + Shouldn'tHappenOrigin {} -> f orig + InstProvidedOrigin {} -> f orig + NonLinearPatternOrigin {} -> f orig + OmittedFieldOrigin {} -> f orig + UsageEnvironmentOf {} -> f orig + FRROrigin {} -> f orig + InstanceSigOrigin {} -> f orig + AmbiguityCheckOrigin {} -> f orig + ImplicitLiftOrigin {} -> f orig + + where + recur o = f orig Semi.<> go o + {- ********************************************************************* * * Defaulting of representational equalities @@ -1004,21 +1098,10 @@ pprNonLinearPatternReason OtherPatternReason = empty -- That is, this function extracts all occurrences of the 'DefaultReprEqOrigin' -- constructor from within a 'CtOrigin'. defaultReprEqOrigins :: CtOrigin -> [(CtOrigin, (TcType, TcType))] -defaultReprEqOrigins = go +defaultReprEqOrigins = foldMapCtOrigin go where go = \case - DefaultReprEqOrigin l r o -> (o, (l, r)) : go o - - -- Handle recursive occurrences of 'CtOrigin' within 'CtOrigin'. - -- TODO: use syb to derive this, so that the following never goes out of date. - ScOrigin cls_or_qc _ -> - case cls_or_qc of - IsClsInst -> [] - IsQC _ o -> go o - KindEqOrigin _ _ o _ -> go o - CycleBreakerOrigin o -> go o - WantedSuperclassOrigin _ o -> go o - + DefaultReprEqOrigin l r o -> [(o, (l, r))] _ -> [] {- ********************************************************************* @@ -1046,6 +1129,37 @@ isPushCallStackOrigin_maybe orig = Just orig_fs where orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig)) +{- ********************************************************************* +* * + HasField and CtOrigin +* * +********************************************************************* -} + +-- | Does this constraint arise from GHC internal mechanisms that desugar to +-- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)? +-- +-- Used in two places: +-- +-- - When reporting an unsolved 'HasField' constraint, to decide whether to +-- print an informative message to the user. +-- See (H2e) in Note [Error messages for unsolved HasField constraints] +-- in GHC.Tc.Errors. +-- - To avoid emitting a poor "incomplete record selector" warning directly +-- in typechecker, in cases when the desugarer will be able to emit a better +-- error message, due to having better pattern match checking information. +-- See (IRS7) in Note [Detecting incomplete record selectors] +-- in GHC.HsToCore.Pmc +isHasFieldOrigin :: CtOrigin -> Bool +isHasFieldOrigin = Semi.getAny . foldMapCtOrigin (Semi.Any . go) + where + go = \case + OccurrenceOf n -> n == getFieldName + OccurrenceOfRecSel {} -> True + RecordFieldProjectionOrigin {} -> True + GetFieldOrigin {} -> True + RecordUpdOrigin {} -> True + _ -> False + {- ************************************************************************ * * ===================================== testsuite/tests/overloadedrecflds/should_compile/T26686.hs ===================================== @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -Wincomplete-record-selectors #-} + +module T26686 where + +import Data.Kind + +data A +data B + +data G = G { f2 :: Int } + +data T x where + TA :: { ta :: G } -> T x + TB :: { tb :: G } -> T B + +data H a = H { f1 :: T a } + +test1_ok :: T A -> G +test1_ok = (.ta) +test2_ok :: T A -> Int +test2_ok = (.ta.f2) +test3_ok :: H A -> G +test3_ok = (.f1.ta) +test4_ok :: H A -> Int +test4_ok = (.f1.ta.f2) + +test1_bad :: T x -> G +test1_bad = (.ta) +test2_bad :: T x -> Int +test2_bad = (.ta.f2) +test3_bad :: H x -> G +test3_bad = (.f1.ta) +test4_bad :: H x -> Int +test4_bad = (.f1.ta.f2) ===================================== testsuite/tests/overloadedrecflds/should_compile/T26686.stderr ===================================== @@ -0,0 +1,16 @@ +T26686.hs:31:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)] + Selecting the record field ‘ta’ may fail for the following constructors: + TB + +T26686.hs:33:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)] + Selecting the record field ‘ta’ may fail for the following constructors: + TB + +T26686.hs:35:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)] + Selecting the record field ‘ta’ may fail for the following constructors: + TB + +T26686.hs:37:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)] + Selecting the record field ‘ta’ may fail for the following constructors: + TB + ===================================== testsuite/tests/overloadedrecflds/should_compile/all.T ===================================== @@ -30,6 +30,7 @@ test('T21720', req_th, compile, ['']) test('T21898', normal, compile, ['']) test('T22160', [extra_files(['T22160_A.hs', 'T22160_B.hs', 'T22160_C.hs'])] , multimod_compile, ['T22160_A T22160_B T22160_C T22160', '-v0']) +test('T26686', normal, compile, ['']) test('DupFldFixity3', normal, compile, ['']) test('overloadedrecflds10' , [extra_files(['OverloadedRecFlds10_A.hs', 'OverloadedRecFlds10_B.hs', 'OverloadedRecFlds10_C.hs'])] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c3e6ba9f03d19a4fa85aee6a4c417… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c3e6ba9f03d19a4fa85aee6a4c417… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] ghci: Mention active language edition in startup banner
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e34cb6da by Adam Gundry at 2026-03-20T12:20:00-04:00 ghci: Mention active language edition in startup banner Per GHC proposal 632, this makes the GHCi startup banner include the active language edition, plus an indication of whether this was the default (as opposed to being explicitly selected via an option such as `-XGHC2024`). For example: ``` $ ghci GHCi, version 9.14.1: https://www.haskell.org/ghc/ :? for help Using default language edition: GHC2024 ghci> ``` Fixes #26037. - - - - - 2 changed files: - ghc/GHCi/UI.hs - ghc/Main.hs Changes: ===================================== ghc/GHCi/UI.hs ===================================== @@ -23,7 +23,8 @@ module GHCi.UI ( GhciSettings(..), defaultGhciSettings, ghciCommands, - ghciWelcomeMsg + ghciWelcomeMsg, + languageEditionMsg ) where -- GHCi @@ -199,6 +200,10 @@ versionString = "GHCi, version " ++ cProjectVersion ghciWelcomeMsg :: String ghciWelcomeMsg = versionString ++ ": https://www.haskell.org/ghc/ :? for help" +languageEditionMsg :: Maybe Language -> String +languageEditionMsg Nothing = "Using default language edition: " ++ show defaultLanguage +languageEditionMsg (Just lang) = "Using language edition: " ++ show lang + ghciCommands :: [Command] ghciCommands = map mkCmd [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap ===================================== ghc/Main.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Platform import GHC.Platform.Host #if defined(HAVE_INTERNAL_INTERPRETER) -import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) +import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings, languageEditionMsg ) #endif import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins ) @@ -334,7 +334,9 @@ showBanner _postLoadMode dflags = do #if defined(HAVE_INTERNAL_INTERPRETER) -- Show the GHCi banner - when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg + when (isInteractiveMode _postLoadMode && verb >= 1) $ + do putStrLn ghciWelcomeMsg + putStrLn $ languageEditionMsg (language dflags) #endif -- Display details of the configuration in verbose mode View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e34cb6da7b980e2ccba320c38006abc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e34cb6da7b980e2ccba320c38006abc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] Lots of wibbles
by Simon Peyton Jones (＠simonpj) 20 Mar '26

20 Mar '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: f8a69d19 by Simon Peyton Jones at 2026-03-20T15:23:42+00:00 Lots of wibbles ..including help from Matthew, to module graph dependencies - - - - - 66 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Ext/Binary.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModSummary.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-prim/ghc-prim.cabal - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/parser/should_fail/T16270h.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8a69d19f61a61831bb74a91e88b9c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8a69d19f61a61831bb74a91e88b9c1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/T17202
by Magnus (＠MangoIV) 20 Mar '26

20 Mar '26

Magnus deleted branch wip/T17202 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Add support for custom external interpreter commands
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: 12fbd7bd by Matthew Pickering at 2026-03-20T14:06:28+00:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 6 changed files: - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout Changes: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -71,6 +71,7 @@ import qualified GHC.Boot.TH.Monad as TH import System.Exit import System.IO import System.IO.Error +import Data.Word (Word8) -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -246,6 +247,11 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) + -- | User-defined request encoded as a tag/payload pair. This is left + -- uninterpreted by GHC and is meant for GHC API applications to be able to supply + -- their own interpreter which understands additional commands. + CustomMessage :: Word8 -> ByteString -> Message ByteString + deriving instance Show (Message a) -- | Used to dynamically create a data constructor's info table at @@ -602,6 +608,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +655,7 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a + CustomMessage tag payload -> putWord8 41 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -125,6 +125,7 @@ run m = case m of Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m + CustomMessage {} -> unexpectedMessage m unexpectedMessage :: Message a -> b unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m) ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,7 +1,11 @@ {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server - ( serv + ( MessageHook + , CustomMessageHandler + , serv + , servWithCustom , defaultServer + , defaultServerWithCustom ) where @@ -10,8 +14,8 @@ import GHCi.Run import GHCi.Signals import GHCi.TH import GHCi.Message -#if defined(wasm32_HOST_ARCH) import Data.ByteString (ByteString) +#if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -22,6 +26,7 @@ import GHC.Wasm.Prim #else import GHCi.Utils #endif +import Data.Word (Word8) import Control.DeepSeq import Control.Exception @@ -36,11 +41,27 @@ import System.IO type MessageHook = Msg -> IO Msg +-- | How to interpret the 'CustomCommand'. +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString) + +noCustomHandler :: CustomMessageHandler +noCustomHandler _ _ = return Nothing + trace :: String -> IO () trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe restore = loop +serv verbose hook pipe restore = + servWithCustom verbose hook pipe restore noCustomHandler + +servWithCustom + :: Bool + -> MessageHook + -> Pipe + -> (forall a .IO a -> IO a) + -> CustomMessageHandler + -> IO () +servWithCustom verbose hook pipe restore customHandler = loop where loop = do when verbose $ trace "reading pipe..." @@ -50,6 +71,7 @@ serv verbose hook pipe restore = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs @@ -61,6 +83,13 @@ serv verbose hook pipe restore = loop writePipe pipe (put r) loop + handleCustom tag payload = do + mresp <- customHandler tag payload + case mresp of + Just resp -> reply resp + Nothing -> + error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + -- Run some TH code, which may interact with GHC by sending -- THMessage requests, and then finally send RunTHDone followed by a -- QResult. For an overview of how TH works with Remote GHCi, see @@ -109,12 +138,24 @@ serv verbose hook pipe restore = loop -- | Default server #if defined(wasm32_HOST_ARCH) defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO () -defaultServer cb_sig cb_recv cb_send = do +defaultServer cb_sig cb_recv cb_send = + defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler + +defaultServerWithCustom + :: Callback (JSVal -> IO ()) + -> Callback (IO JSUint8Array) + -> Callback (JSUint8Array -> IO ()) + -> CustomMessageHandler + -> IO () +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do args <- getArgs let rest = args #else defaultServer :: IO () -defaultServer = do +defaultServer = defaultServerWithCustom noCustomHandler + +defaultServerWithCustom :: CustomMessageHandler -> IO () +defaultServerWithCustom customHandler = do args <- getArgs (outh, inh, rest) <- case args of @@ -152,7 +193,7 @@ defaultServer = do putStrLn "Waiting 3s" threadDelay 3000000 - uninterruptibleMask $ serv verbose hook pipe + uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-} +module Main (main) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Word (Word8) +import GHCi.Message + ( Message(..) + , mkPipeFromHandles + , remoteCall + , Pipe + ) +import GHCi.Server + ( CustomMessageHandler + , defaultServerWithCustom + ) +import System.Environment + ( getArgs + , getExecutablePath + , getProgName + , withArgs + ) +import System.Exit (exitFailure) +import System.IO + ( Handle + , BufferMode(..) + , hSetBuffering + , hSetBinaryMode + , hClose + , hPutStrLn + , stderr + ) +import System.Posix.IO + ( createPipe + , fdToHandle + , setFdOption + , FdOption(CloseOnExec) + ) +import System.Process + ( createProcess + , proc + , std_in + , std_out + , std_err + , StdStream(Inherit) + , terminateProcess + , waitForProcess + , ProcessHandle + ) +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +-- Shared request/response definitions and helpers + +data ClientCommand a where + SquareCommand :: Int -> ClientCommand Int + MulCommand :: Int -> Int -> ClientCommand Int + +deriving instance (Show (ClientCommand a)) + +data Some c f where + Some :: c a => f a -> Some c f + + +instance Bin.Binary (Some Bin.Binary ClientCommand) where + put (Some i) = + case i of + SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n + MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n + + get = do + (tag :: Word8) <- Bin.get + fmap Some $ case tag of + 0 -> SquareCommand <$> Bin.get + 1 -> MulCommand <$> Bin.get <*> Bin.get + + +customTag :: Word8 +customTag = 0x42 + +encodeLazy :: Bin.Binary a => a -> BS.ByteString +encodeLazy = BL.toStrict . Bin.encode + +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a +decodeLazy bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +-------------------------------------------------------------------------------- +-- Mode selection + +data Mode + = RunClient Int + | RunServer [String] -- forwarded to GHCi.Server + +defaultInput :: Int +defaultInput = 12 + +parseMode :: [String] -> Either String Mode +parseMode [] = Right (RunClient defaultInput) +parseMode ["client"] = Right (RunClient defaultInput) +parseMode ["client", nStr] = + case readMaybe nStr of + Just n -> Right (RunClient n) + Nothing -> Left $ "Unable to parse integer argument: " ++ nStr +parseMode ("client":_) = Left "Too many arguments for client mode." +parseMode ("server":rest) = Right (RunServer rest) +parseMode args = Left "Unknown mode, use client/server" + +usage :: IO () +usage = do + prog <- getProgName + putStrLn $ unlines + [ "Usage:" + , " " ++ prog ++ " [client [n]] Run the client and square n (default 12)." + , " " ++ prog ++ " server <write-fd> <read-fd> Run as an iserv process." + ] + +-------------------------------------------------------------------------------- +-- Client/server drivers + +main :: IO () +main = do + args <- getArgs + case parseMode args of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right (RunClient n) -> runClient n + Right (RunServer serverArgs) -> + withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand)) + +handleClientCommand :: ClientCommand a -> IO a +handleClientCommand (SquareCommand n) = pure $ n * n +handleClientCommand (MulCommand n m) = pure $ n * m + + +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a +customMessage pipe c = do + let payload = encodeLazy (Some @Bin.Binary c) + putStrLn $ "Sending: " ++ show c + respBytes <- remoteCall pipe (CustomMessage customTag payload) + case decodeLazy respBytes of + Left err -> error $ "Decode error: " ++ err + Right res -> pure res + + +runClient :: Int -> IO () +runClient input = do + serverExe <- getExecutablePath + withServer serverExe $ \hFromServer hToServer -> do + pipe <- mkPipeFromHandles hFromServer hToServer + res <- customMessage pipe (SquareCommand input) + putStrLn $ "Square returned: " ++ show res + res2 <- customMessage pipe (MulCommand 2 res) + putStrLn $ "Mul returned: " ++ show res2 + +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a +withServer serverExe action = do + (ghcRead, serverWrite) <- createPipe + (serverRead, ghcWrite) <- createPipe + mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead] + let args = ["server", show serverWrite, show serverRead] + (_, _, _, ph) <- createProcess (proc serverExe args) + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + bracket (mkHandles ghcRead ghcWrite) + (\(hFromServer, hToServer) -> do + hClose hFromServer + hClose hToServer + terminateProcess ph + void (waitForProcess ph)) + (\(hFromServer, hToServer) -> action hFromServer hToServer) + where + mkHandles r w = do + hR <- fdToHandle r + hW <- fdToHandle w + mapM_ (`hSetBuffering` NoBuffering) [hR, hW] + mapM_ (`hSetBinaryMode` True) [hR, hW] + pure (hR, hW) + +-------------------------------------------------------------------------------- +-- Custom handler + +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler +customHandler handler tag payload + | tag == customTag = + case decodeLazy payload of + Left err -> do + hPutStrLn stderr $ "Custom handler decode error: " ++ err + pure Nothing + Right (Some @Bin.Binary r) -> do + res <- handler r + pure . Just $ encodeLazy res + | otherwise = pure Nothing ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -0,0 +1,10 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , when(config.cross, skip) + , req_process + , req_interp + , omit_ways(prof_ways) + ], + multimod_compile_and_run, + ['Main.hs', '-package ghci']) ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout ===================================== @@ -0,0 +1,4 @@ +Sending: SquareCommand 12 +Square returned: 144 +Sending: MulCommand 2 144 +Mul returned: 288 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12fbd7bde6365a8f2d4f750f3b23090… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12fbd7bde6365a8f2d4f750f3b23090… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Apply 1 suggestion(s) to 1 file(s)
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: ee594de9 by Rodrigo Mesquita at 2026-03-20T14:05:30+00:00 Apply 1 suggestion(s) to 1 file(s) Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 1 changed file: - testsuite/tests/ghci/custom-external-interpreter-commands/all.T Changes: ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -1,8 +1,7 @@ test('custom-external-interpreter-commands', [ extra_files(['Main.hs']) , windows_skip - , js_skip - , wasm_skip + , when(config.cross, skip) , req_process , req_interp , omit_ways(prof_ways) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee594de90f159204bffb0f58bad79d4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee594de90f159204bffb0f58bad79d4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Fix CStub printing
by Hannes Siebenhandl (＠fendor) 20 Mar '26

20 Mar '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 661b24c6 by fendor at 2026-03-20T14:38:34+01:00 Fix CStub printing - - - - - 1 changed file: - compiler/GHC/Driver/CodeOutput.hs Changes: ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -346,15 +346,15 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs pprCStubInitFiniDecls :: Platform -> CStub -> SDoc pprCStubInitFiniDecls platform cstub = - vcat (zipWith (pprInitOrFiniDecl ".init_array") [0 :: Int ..] (getInitializers cstub)) - $$ vcat (zipWith (pprInitOrFiniDecl ".fini_array") [0 :: Int ..] (getFinalizers cstub)) + vcat (zipWith (pprInitOrFiniDecl "ini" ".init_array") [0 :: Int ..] (getInitializers cstub)) + $$ vcat (zipWith (pprInitOrFiniDecl "fini" ".fini_array") [0 :: Int ..] (getFinalizers cstub)) where - pprInitOrFiniDecl :: String -> Int -> CLabel -> SDoc - pprInitOrFiniDecl section_name n lbl = + pprInitOrFiniDecl :: String -> String -> Int -> CLabel -> SDoc + pprInitOrFiniDecl suf section_name n lbl = vcat [ hsep [text "extern void", pprCLabel platform lbl, text "(void);"] , hsep [ text "static void (*" - <> text "__ghc_init_fini_" + <> text "__ghc_" <> text suf <> text "_" <> int n <> text ")(void)" , text "__attribute__((used, section(" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/661b24c658a9b86139b1758cb5bfc6b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/661b24c658a9b86139b1758cb5bfc6b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-external-custom-commands] Add support for custom external interpreter commands
by Rodrigo Mesquita (＠alt-romes) 20 Mar '26

20 Mar '26

Rodrigo Mesquita pushed to branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC Commits: fa21b4e8 by Matthew Pickering at 2026-03-20T13:30:25+00:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 6 changed files: - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout Changes: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -71,6 +71,7 @@ import qualified GHC.Boot.TH.Monad as TH import System.Exit import System.IO import System.IO.Error +import Data.Word (Word8) -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -246,6 +247,11 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) + -- | User-defined request encoded as a tag/payload pair. This is left + -- uninterpreted by GHC and is meant for GHC API applications to be able to supply + -- their own interpreter which understands additional commands. + CustomMessage :: Word8 -> ByteString -> Message ByteString + deriving instance Show (Message a) -- | Used to dynamically create a data constructor's info table at @@ -602,6 +608,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +655,7 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a + CustomMessage tag payload -> putWord8 41 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -125,6 +125,7 @@ run m = case m of Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m + CustomMessage {} -> unexpectedMessage m unexpectedMessage :: Message a -> b unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m) ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,7 +1,11 @@ {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server - ( serv + ( MessageHook + , CustomMessageHandler + , serv + , servWithCustom , defaultServer + , defaultServerWithCustom ) where @@ -10,8 +14,8 @@ import GHCi.Run import GHCi.Signals import GHCi.TH import GHCi.Message -#if defined(wasm32_HOST_ARCH) import Data.ByteString (ByteString) +#if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -22,6 +26,7 @@ import GHC.Wasm.Prim #else import GHCi.Utils #endif +import Data.Word (Word8) import Control.DeepSeq import Control.Exception @@ -36,11 +41,27 @@ import System.IO type MessageHook = Msg -> IO Msg +-- | How to interpret the 'CustomCommand'. +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString) + +noCustomHandler :: CustomMessageHandler +noCustomHandler _ _ = return Nothing + trace :: String -> IO () trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe restore = loop +serv verbose hook pipe restore = + servWithCustom verbose hook pipe restore noCustomHandler + +servWithCustom + :: Bool + -> MessageHook + -> Pipe + -> (forall a .IO a -> IO a) + -> CustomMessageHandler + -> IO () +servWithCustom verbose hook pipe restore customHandler = loop where loop = do when verbose $ trace "reading pipe..." @@ -50,6 +71,7 @@ serv verbose hook pipe restore = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs @@ -61,6 +83,13 @@ serv verbose hook pipe restore = loop writePipe pipe (put r) loop + handleCustom tag payload = do + mresp <- customHandler tag payload + case mresp of + Just resp -> reply resp + Nothing -> + error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + -- Run some TH code, which may interact with GHC by sending -- THMessage requests, and then finally send RunTHDone followed by a -- QResult. For an overview of how TH works with Remote GHCi, see @@ -109,12 +138,24 @@ serv verbose hook pipe restore = loop -- | Default server #if defined(wasm32_HOST_ARCH) defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO () -defaultServer cb_sig cb_recv cb_send = do +defaultServer cb_sig cb_recv cb_send = + defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler + +defaultServerWithCustom + :: Callback (JSVal -> IO ()) + -> Callback (IO JSUint8Array) + -> Callback (JSUint8Array -> IO ()) + -> CustomMessageHandler + -> IO () +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do args <- getArgs let rest = args #else defaultServer :: IO () -defaultServer = do +defaultServer = defaultServerWithCustom noCustomHandler + +defaultServerWithCustom :: CustomMessageHandler -> IO () +defaultServerWithCustom customHandler = do args <- getArgs (outh, inh, rest) <- case args of @@ -152,7 +193,7 @@ defaultServer = do putStrLn "Waiting 3s" threadDelay 3000000 - uninterruptibleMask $ serv verbose hook pipe + uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-} +module Main (main) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Word (Word8) +import GHCi.Message + ( Message(..) + , mkPipeFromHandles + , remoteCall + , Pipe + ) +import GHCi.Server + ( CustomMessageHandler + , defaultServerWithCustom + ) +import System.Environment + ( getArgs + , getExecutablePath + , getProgName + , withArgs + ) +import System.Exit (exitFailure) +import System.IO + ( Handle + , BufferMode(..) + , hSetBuffering + , hSetBinaryMode + , hClose + , hPutStrLn + , stderr + ) +import System.Posix.IO + ( createPipe + , fdToHandle + , setFdOption + , FdOption(CloseOnExec) + ) +import System.Process + ( createProcess + , proc + , std_in + , std_out + , std_err + , StdStream(Inherit) + , terminateProcess + , waitForProcess + , ProcessHandle + ) +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +-- Shared request/response definitions and helpers + +data ClientCommand a where + SquareCommand :: Int -> ClientCommand Int + MulCommand :: Int -> Int -> ClientCommand Int + +deriving instance (Show (ClientCommand a)) + +data Some c f where + Some :: c a => f a -> Some c f + + +instance Bin.Binary (Some Bin.Binary ClientCommand) where + put (Some i) = + case i of + SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n + MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n + + get = do + (tag :: Word8) <- Bin.get + fmap Some $ case tag of + 0 -> SquareCommand <$> Bin.get + 1 -> MulCommand <$> Bin.get <*> Bin.get + + +customTag :: Word8 +customTag = 0x42 + +encodeLazy :: Bin.Binary a => a -> BS.ByteString +encodeLazy = BL.toStrict . Bin.encode + +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a +decodeLazy bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +-------------------------------------------------------------------------------- +-- Mode selection + +data Mode + = RunClient Int + | RunServer [String] -- forwarded to GHCi.Server + +defaultInput :: Int +defaultInput = 12 + +parseMode :: [String] -> Either String Mode +parseMode [] = Right (RunClient defaultInput) +parseMode ["client"] = Right (RunClient defaultInput) +parseMode ["client", nStr] = + case readMaybe nStr of + Just n -> Right (RunClient n) + Nothing -> Left $ "Unable to parse integer argument: " ++ nStr +parseMode ("client":_) = Left "Too many arguments for client mode." +parseMode ("server":rest) = Right (RunServer rest) +parseMode args = Left "Unknown mode, use client/server" + +usage :: IO () +usage = do + prog <- getProgName + putStrLn $ unlines + [ "Usage:" + , " " ++ prog ++ " [client [n]] Run the client and square n (default 12)." + , " " ++ prog ++ " server <write-fd> <read-fd> Run as an iserv process." + ] + +-------------------------------------------------------------------------------- +-- Client/server drivers + +main :: IO () +main = do + args <- getArgs + case parseMode args of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right (RunClient n) -> runClient n + Right (RunServer serverArgs) -> + withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand)) + +handleClientCommand :: ClientCommand a -> IO a +handleClientCommand (SquareCommand n) = pure $ n * n +handleClientCommand (MulCommand n m) = pure $ n * m + + +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a +customMessage pipe c = do + let payload = encodeLazy (Some @Bin.Binary c) + putStrLn $ "Sending: " ++ show c + respBytes <- remoteCall pipe (CustomMessage customTag payload) + case decodeLazy respBytes of + Left err -> error $ "Decode error: " ++ err + Right res -> pure res + + +runClient :: Int -> IO () +runClient input = do + serverExe <- getExecutablePath + withServer serverExe $ \hFromServer hToServer -> do + pipe <- mkPipeFromHandles hFromServer hToServer + res <- customMessage pipe (SquareCommand input) + putStrLn $ "Square returned: " ++ show res + res2 <- customMessage pipe (MulCommand 2 res) + putStrLn $ "Mul returned: " ++ show res2 + +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a +withServer serverExe action = do + (ghcRead, serverWrite) <- createPipe + (serverRead, ghcWrite) <- createPipe + mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead] + let args = ["server", show serverWrite, show serverRead] + (_, _, _, ph) <- createProcess (proc serverExe args) + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + bracket (mkHandles ghcRead ghcWrite) + (\(hFromServer, hToServer) -> do + hClose hFromServer + hClose hToServer + terminateProcess ph + void (waitForProcess ph)) + (\(hFromServer, hToServer) -> action hFromServer hToServer) + where + mkHandles r w = do + hR <- fdToHandle r + hW <- fdToHandle w + mapM_ (`hSetBuffering` NoBuffering) [hR, hW] + mapM_ (`hSetBinaryMode` True) [hR, hW] + pure (hR, hW) + +-------------------------------------------------------------------------------- +-- Custom handler + +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler +customHandler handler tag payload + | tag == customTag = + case decodeLazy payload of + Left err -> do + hPutStrLn stderr $ "Custom handler decode error: " ++ err + pure Nothing + Right (Some @Bin.Binary r) -> do + res <- handler r + pure . Just $ encodeLazy res + | otherwise = pure Nothing ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -0,0 +1,11 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , js_skip + , wasm_skip + , req_process + , req_interp + , omit_ways(prof_ways) + ], + multimod_compile_and_run, + ['Main.hs', '-package ghci']) ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout ===================================== @@ -0,0 +1,4 @@ +Sending: SquareCommand 12 +Square returned: 144 +Sending: MulCommand 2 144 +Mul returned: 288 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21b4e88863803640451ec7f534ea3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21b4e88863803640451ec7f534ea3… You're receiving this email because of your account on gitlab.haskell.org.

1 0