July 2026 - ghc-commits

[Git][ghc/ghc][master] Add -Wdefaulted-callstack
by Marge Bot (＠marge-bot) 25 Jul '26

25 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 815149f3 by Andrzej Rybczak at 2026-07-25T15:06:43+00:00 Add -Wdefaulted-callstack Adds a new warning, -Wdefaulted-callstack, which warns when an implicit CallStack parameter is defaulted to the empty stack. In particular, this includes call sites where a function with a HasCallStack constraint is called from a definition that does *not* provide one. At such call sites the call stack is cut off and does not include the enclosing definition's callers, which can be a source of surprise if the user wants complete call stacks. Closes #27077. - - - - - 21 changed files: - + changelog.d/warn-defaulted-callstack - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Error/Codes.hs - docs/users_guide/using-warnings.rst - libraries/base/changelog.md - libraries/base/src/GHC/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - 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/typecheck/should_compile/WarnDefaultedCallStack.hs - + testsuite/tests/typecheck/should_compile/WarnDefaultedCallStack.stderr - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== changelog.d/warn-defaulted-callstack ===================================== @@ -0,0 +1,12 @@ +section: compiler +issues: #27077 +mrs: !16174 +synopsis: Add ``-Wdefaulted-callstack`` +description: + GHC now supports a new warning, ``-Wdefaulted-callstack``, which warns when an + implicit ``CallStack`` parameter is defaulted to the empty stack. In + particular, this includes call sites where a function with a ``HasCallStack`` + constraint is called from a definition that does *not* provide one. At such + call sites the call stack is cut off and does not include the enclosing + definition's callers, which can be a source of surprise if the user wants + complete call stacks. ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1135,6 +1135,7 @@ data WarningFlag = | Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14 | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 + | Opt_WarnDefaultedCallStack -- ^ @since 10.2 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1258,6 +1259,7 @@ warnFlagNames wflag = case wflag of Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| [] Opt_WarnUnrecognisedModifiers -> "unrecognised-modifiers" :| [] Opt_WarnSemaphoreOpenFailure -> "semaphore-open-failure" :| [] + Opt_WarnDefaultedCallStack -> "defaulted-callstack" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2446,6 +2446,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnPatternNamespaceSpecifier -> warnSpec x Opt_WarnUnrecognisedModifiers -> warnSpec x Opt_WarnSemaphoreOpenFailure -> warnSpec x + Opt_WarnDefaultedCallStack -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1941,6 +1941,19 @@ instance Diagnostic TcRnMessage where = vcat [ text "Future versions of GHC will turn this warning into an error." ] proposal = vcat [ text "See GHC Proposal #330." ] + TcRnDefaultedCallStack ct_loc + -> mkSimpleDecorated $ case ctLocOrigin ct_loc of + -- Suggestion makes sense only for this particular case. + PushedCallStackOrigin{} -> vcat [ header, suggestion ] + _ -> header + where + header, suggestion :: SDoc + header + = vcat [ text "Defaulting to the empty call stack" + , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ] + suggestion + = text "Add a" <+> quotes (text "HasCallStack") <+> + text "constraint to the enclosing definition to extend the call stack." TcRnImplicitImportOfPrelude -> mkSimpleDecorated $ text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported." @@ -2671,6 +2684,8 @@ instance Diagnostic TcRnMessage where -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances TcRnDefaultedExceptionContext{} -> WarningWithFlag Opt_WarnDefaultedExceptionContext + TcRnDefaultedCallStack{} + -> WarningWithFlag Opt_WarnDefaultedCallStack TcRnImplicitImportOfPrelude {} -> WarningWithFlag Opt_WarnImplicitPrelude TcRnMissingMain {} @@ -3404,6 +3419,8 @@ instance Diagnostic TcRnMessage where -> suggestNonCanonicalDefinition reason TcRnDefaultedExceptionContext _ -> noHints + TcRnDefaultedCallStack{} + -> noHints TcRnImplicitImportOfPrelude {} -> noHints TcRnMissingMain {} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -4426,6 +4426,17 @@ data TcRnMessage where -} TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage + {-| TcRnDefaultedCallStack is a warning that is triggered when an implicit + @CallStack@ constraint is defaulted to the empty call stack because there + is no enclosing @HasCallStack@ constraint to solve it from. The 'CtLoc' is + the location and origin of the defaulted constraint. + + See Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. + + Test cases: WarnDefaultedCallStack + -} + TcRnDefaultedCallStack :: CtLoc -> TcRnMessage + {-| TcRnOutOfArityTyVar is an error raised when the arity of a type synonym (as determined by the SAKS and the LHS) is insufficiently high to accommodate an implicit binding for a free variable that occurs in the ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -461,7 +461,12 @@ defaultCallStack :: CtDefaultingStrategy defaultCallStack ct | ClassPred cls tys <- classifyPredType (ctPred ct) , isJust (isCallStackPred cls tys) - = do { solveCallStack (ctEvidence ct) EvCsEmpty + = do { dflags <- getDynFlags + -- See Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. + ; when (wopt Opt_WarnDefaultedCallStack dflags) $ + do { let loc = ctLoc ct + ; ctLocWarnTcS loc (TcRnDefaultedCallStack loc) } + ; solveCallStack (ctEvidence ct) EvCsEmpty ; return emptyWC } | otherwise = noDefaulting ct ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -25,8 +25,6 @@ import GHC.Tc.Solver.Types import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify( uType, mightEqualLater ) -import GHC.Hs.Type( HsIPName(..) ) - import GHC.Core import GHC.Core.Make import GHC.Core.Type @@ -55,7 +53,6 @@ import GHC.Utils.Misc import GHC.Unit.Module import GHC.Data.Bag -import GHC.Data.FastString import GHC.Driver.DynFlags @@ -121,8 +118,8 @@ canDictCt ev cls tys -- so set the fuel to doNotExpand to avoid repeating expansion | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev - , Just ip_name <- isCallStackPred cls tys - , Just fun_fs <- isPushCallStackOrigin_maybe orig + , isJust (isCallStackPred cls tys) + , Just fun_fs <- isPushCallStackOrigin_maybe orig -- If we're given a CallStack constraint that arose from a function -- call, we need to push the current call-site onto the stack instead -- of solving it directly from a given. @@ -132,11 +129,13 @@ canDictCt ev cls tys do { -- First we emit a new constraint that will capture the -- given CallStack. - let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName $ fastStringToShortText ip_name)) - -- We change the origin to IPOccOrigin so - -- this rule does not fire again. + let new_loc = setCtLocOrigin loc (PushedCallStackOrigin fun_fs) + -- PushedCallStackOrigin solves like IPOccOrigin, so + -- this rule does not fire again, but retains fun_fs + -- for -Wdefaulted-callstack. -- See Note [Overview of implicit CallStacks] -- in GHC.Tc.Types.Evidence + -- and Note [Warn about defaulted CallStacks] ; new_ev <- CtWanted <$> newWantedEvVarNC new_loc rws pred @@ -214,6 +213,80 @@ evCallStack pred (EvCsPushCall fs loc tm) ; return (mkCoreApps (Var push_cs_id) [mkCoreTup [name_expr, loc_expr], outer_stk]) } +{- Note [Warn about defaulted CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A call stack only records the chain of calls as long as every function in the +chain carries a HasCallStack constraint. When a function with a HasCallStack +constraint is called from a definition that does /not/ have one, the implicit +CallStack parameter emitted for the call cannot be solved from any enclosing +Given and is defaulted to the empty call stack (see Note [Overview of implicit +CallStacks] in GHC.Tc.Types.Evidence, point 4): the stack stops at this call +site, omitting the caller and everything above it. + +This can be just what you want; e.g. perhaps you selectively add some +HasCallStack constraints to help you isolate the caller of a failing call to +`head`. But it can also be a source of surprise if you want complete call +stacks. Hence, `-Wdefaulted-callstack` reports every such defaulting point +(including a bare use of an implicit parameter of type CallStack that defaults). + +Examples: + + bad :: Int + bad = error "boom" -- -Wdefaulted-callstack fires: `bad` has no + -- HasCallStack constraint, so the call stack for the + -- call to `error` is defaulted to the empty stack + + good :: HasCallStack => Int + good = error "boom" + x -- no warning: the call extends `good`'s call stack + where + x = error "splat" -- no warning either, even though `x` has no + -- HasCallStack constraint of its own: `good`'s + -- HasCallStack brings a `?callStack` Given into scope + -- over the whole of `good`, including its where/let + -- bindings, so this call is solved from that Given + -- (it floats up to it) and extends `good`'s stack + + stk :: CallStack + stk = ?stk -- -Wdefaulted-callstack fires: implicit parameters + -- of type CallStack default too + +We emit the warning from `defaultCallStack` (in GHC.Tc.Solver.Default), the one +and only place a CallStack is solved with the empty stack `EvCsEmpty`. +Defaulting runs once, at the top level (`simplifyTopWanteds`), after every +constraint has had the chance to float up and be solved against all enclosing +Givens, so a constraint that reaches it really is defaulted. + +The message renders the defaulted constraint's `CtOrigin` (just like +`-Wdefaulted-exception-context`): for a function call (plan PUSH, see Note +[Overview of implicit CallStacks] in GHC.Tc.Types.Evidence, point 2) that origin +is `PushedCallStackOrigin fun_fs`, naming the called function; for a bare use of +an implicit parameter of type `CallStack` it is `IPOccOrigin`. Either way the +`CtLoc` points at the use site. + +In cases when a HasCallStack constraint cannot be supplied using a type +signature (e.g. the body of `main` or a method in an instance of a class whose +type signature lacks a HasCallStack constraint) the user can silence the warning +by bringing an empty stack into scope explicitly with +`GHC.Stack.withEmptyCallStack`: + +main :: IO () +main = withEmptyCallStack $ do + ... + error "oops" -- no warning here + ... + +Caveat (under-reporting within a single definition): identical Wanted CallStack +constraints are CSE'd by the constraint solver, so several defaulting call sites +within the /same/ definition collapse to a single warning: + + twoErrors :: Int + twoErrors = error "a" + error "b" -- one -Wdefaulted-callstack warning + +We do, however, report defaulting in /every/ top-level definition (see Note +[When to build an implication] in GHC.Tc.Utils.Unify). This is what counts, +because it allows the user to take action on all affected bindings at once. +-} + {- Note [Solving CallStack constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence. @@ -231,7 +304,7 @@ Suppose f :: HasCallStack => blah. Then pushing the call-site info on the stack, and changing the CtOrigin to record that has been done. Bind: s1 = pushCallStack <site-info> s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin + [W] s2 :: IP "callStack" CallStack -- CtOrigin = PushedCallStackOrigin f * Then, and only then, we can solve the constraint from an enclosing Given. ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -1137,7 +1137,7 @@ implicit parameter is not important, see (CS5) below) are solved as follows: We do /not/ solve this constraint from Givens, or from other Wanteds. Rather, have a built-in mechanism in that solves it thus: d := EvCsPushCall "foo" <details of call-site of `foo`> d2 - [W] d2 :: (?stk :: CallStack) CtOrigin = IPOccOrigin + [W] d2 :: (?stk :: CallStack) CtOrigin = PushedCallStackOrigin "foo" That is, `d` is a call-stack that has the `foo` call-site pushed on top of `d2`, which can now be solved normally (as in (1) above). This is done as follows: @@ -1148,6 +1148,9 @@ implicit parameter is not important, see (CS5) below) are solved as follows: * solve it normally (plan NORMAL above) - IPOccOrigin (discussed above) + - PushedCallStackOrigin (the new Wanted emitted by plan PUSH; behaves + like IPOccOrigin but retains the function name for + -Wdefaulted-callstack, see Note [Warn about defaulted CallStacks]) - GivenOrigin (see (CS1) below) * push an item on the stack and emit a new constraint (plan PUSH above) @@ -1189,6 +1192,10 @@ the resulting CallStack will include the call to `undefined` in `head` and the call to `error` in `undefined`, but *not* the call to `head` in `g`, because `head` did not explicitly request a CallStack. +The `-Wdefaulted-callstack` warning flags exactly these points where the stack +is defaulted to empty (here, the call to `undefined` in `head`). See +Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. + Wrinkles @@ -1240,11 +1247,14 @@ Wrinkles call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) (CS7) When we emit a new wanted CallStack in plan PUSH we set its origin to - `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` - (see GHC.Tc.Solver.Dict.tryInertDicts). - - This is a bit shady, but is how we ensure that the new wanted is - solved like a regular IP. + `PushedCallStackOrigin func` instead of the original `OccurrenceOf func` + (see GHC.Tc.Solver.Dict.canDictCt). + + This is a bit shady, but is how we ensure that the new wanted is solved like + a regular IP (isPushCallStackOrigin_maybe returns Nothing for it, as for + IPOccOrigin). Unlike IPOccOrigin it retains the called function's name, which + -Wdefaulted-callstack uses if the stack is ultimately defaulted to empty. + See Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. -} mkEvScSelectors -- Assume class (..., D ty, ...) => C a b ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -412,6 +412,13 @@ data CtOrigin CtOrigin -- CtOrigin of the original type equality | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + | PushedCallStackOrigin FastString + -- ^ The Wanted CallStack emitted by plan PUSH (see Note [Overview of + -- implicit CallStacks] in GHC.Tc.Types.Evidence) when a call site for the + -- named function is pushed onto the call stack. Solved like + -- 'IPOccOrigin', but retains the function name so that + -- @-Wdefaulted-callstack@ can report which call had its stack defaulted. + -- See Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. | OverLabelOrigin FastString -- Occurrence of an overloaded label | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal @@ -786,6 +793,7 @@ ppr_br (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] ppr_br (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] ppr_br AppOrigin = text "an application" ppr_br (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +ppr_br (PushedCallStackOrigin fs) = hsep [text "a use of", quotes (ftext fs)] ppr_br (OverLabelOrigin l) = hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] ppr_br (RecordUpdOrigin {}) = text "a record update" @@ -897,6 +905,7 @@ foldMapCtOrigin f = go SpecPragOrigin {} -> f orig TypeEqOrigin {}-> f orig IPOccOrigin {} -> f orig + PushedCallStackOrigin {} -> f orig OverLabelOrigin {} -> f orig LiteralOrigin {} -> f orig QualLiteralOrigin {} -> f orig @@ -978,6 +987,7 @@ isPushCallStackOrigin_maybe :: CtOrigin -> Maybe FastString isPushCallStackOrigin_maybe (GivenOrigin {}) = Nothing isPushCallStackOrigin_maybe (GivenSCOrigin {}) = Nothing isPushCallStackOrigin_maybe (IPOccOrigin {}) = Nothing +isPushCallStackOrigin_maybe (PushedCallStackOrigin {}) = Nothing isPushCallStackOrigin_maybe (OccurrenceOf fun) = Just (occNameFS (getOccName fun)) isPushCallStackOrigin_maybe orig = Just orig_fs -- This fall-through case is important to deal with call stacks ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -587,7 +587,8 @@ implicationNeeded skol_info skol_tvs given -- we must build an implication ; return (gopt Opt_DeferTypeErrors dflags || gopt Opt_DeferTypedHoles dflags || - gopt Opt_DeferOutOfScopeVariables dflags) } } + gopt Opt_DeferOutOfScopeVariables dflags || + wopt Opt_WarnDefaultedCallStack dflags ) } } | otherwise -- Non-empty skolems or givens = return True -- Definitely need an implication @@ -676,6 +677,14 @@ take care: literally nothing to do with each other. #14185 is an example. Building an implication keeps them separate. +* If -Wdefaulted-callstack is on, we build an implication around each top-level + binding so that their implicit CallStack parameters are solved (and hence + defaulted) in isolation. Otherwise each top-level binding's wanteds float + into a single pool and end up CSE'd, so only one of them reaches + `defaultCallStack` where the warning is generated; the per-binding implication + lets us report every top-level definition that defaults its call stack. See + also Note [Warn about defaulted CallStacks] in GHC.Tc.Solver.Dict. + Note [Herald for matchExpectedFunTys] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'herald' always looks like: ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -676,6 +676,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "NonCanonicalMonoid" = 50928 GhcDiagnosticCode "NonCanonicalMonad" = 22705 GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235 + GhcDiagnosticCode "TcRnDefaultedCallStack" = 39361 GhcDiagnosticCode "TcRnImplicitImportOfPrelude" = 20540 GhcDiagnosticCode "TcRnMissingMain" = 67120 GhcDiagnosticCode "TcRnGhciUnliftedBind" = 17999 ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2619,7 +2619,7 @@ of ``-W(no-)*``. implicit parameter is defaulted to :base-ref:`Control.Exception.Context.emptyExceptionContext`. :type: dynamic - :reverse: -Wnop-defaulted-exception-context + :reverse: -Wno-defaulted-exception-context :since: 9.10.1 @@ -2631,6 +2631,42 @@ of ``-W(no-)*``. evidence is available. As this behavior may result in dropped exception context this warning is provided to give notice when defaulting occurs. +.. ghc-flag:: -Wdefaulted-callstack + :shortdesc: warn when an implicit :base-ref:`GHC.Stack.CallStack` parameter + is defaulted to the empty stack. + :type: dynamic + :reverse: -Wno-defaulted-callstack + + :since: 10.2.1 + + When a function with a :base-ref:`GHC.Stack.HasCallStack` constraint is + called from a definition that does *not* provide one, the implicit + :base-ref:`GHC.Stack.CallStack` parameter is defaulted to the empty stack, + so at such call sites the call stack is cut off and does not include the + enclosing definition's callers. + + This might be desirable; e.g. perhaps the user selectively added some + :base-ref:`GHC.Stack.HasCallStack` constraints to help isolate the caller of + a failing call to ``head``. But it can also be a source of surprise if the + user wants complete call stacks. Hence, ``-Wdefaulted-callstack`` (off by + default) reports every such defaulting point (including a bare use of an + implicit parameter of type :base-ref:`GHC.Stack.CallStack` that defaults). + + In cases when a :base-ref:`GHC.Stack.HasCallStack` constraint cannot be + supplied using a type signature (e.g. the body of ``main`` or a method in an + instance of a class whose type signature lacks a + :base-ref:`GHC.Stack.HasCallStack` constraint), the user can silence the + warning by bringing an empty stack into scope explicitly with + :base-ref:`GHC.Stack.withEmptyCallStack`: + + .. code-block:: haskell + + main :: IO () + main = withEmptyCallStack $ do + ... + error "oops" -- no warning here + ... + .. ghc-flag:: -Wview-pattern-signatures :shortdesc: warn when a view pattern is used with type signature without explicit parens ===================================== libraries/base/changelog.md ===================================== @@ -8,6 +8,7 @@ * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378)) * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413)) + * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/base/src/GHC/Stack.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Stack prettyCallStack, pushCallStack, withFrozenCallStack, + withEmptyCallStack, -- * Source locations SrcLoc(..), prettySrcLoc, @@ -49,4 +50,4 @@ module GHC.Stack renderStack ) where -import GHC.Internal.Stack \ No newline at end of file +import GHC.Internal.Stack ===================================== libraries/ghc-internal/src/GHC/Internal/Stack.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Internal.Stack ( -- * HasCallStack call stacks CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack, fromCallSiteList, getCallStack, popCallStack, - pushCallStack, withFrozenCallStack, + pushCallStack, withFrozenCallStack, withEmptyCallStack, prettyCallStackLines, prettyCallStack, -- * Source locations @@ -105,6 +105,23 @@ withFrozenCallStack do_this = let ?callStack = freezeCallStack (popCallStack callStack) in do_this +-- | Explicitly bring the empty call stack into scope. +-- +-- Mostly useful for silencing warnings generated by @-Wdefaulted-callstack@ in +-- places such as: +-- +-- - The body of a class method in an instance of an externally defined type +-- class whose type signature doesn't contain a 'HasCallStack' constraint. +-- +-- - The body of the @main@ function. +-- +-- @since 4.24.0.0 +withEmptyCallStack :: (HasCallStack => a) -> a +withEmptyCallStack do_this = + -- See Note [Warn about defaulted CallStacks] + let ?callStack = emptyCallStack + in do_this + -- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot -- files. See Note [Definition of CallStack] ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -9047,6 +9047,7 @@ module GHC.Stack where pushCallStack :: ([GHC.Internal.Types.Char], SrcLoc) -> CallStack -> CallStack renderStack :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String whoCreated :: forall a. a -> GHC.Internal.Types.IO [GHC.Internal.Base.String] + withEmptyCallStack :: forall a. (HasCallStack => a) -> a withFrozenCallStack :: forall a. HasCallStack => (HasCallStack => a) -> a module GHC.Stack.CCS where ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -9085,6 +9085,7 @@ module GHC.Stack where pushCallStack :: ([GHC.Internal.Types.Char], SrcLoc) -> CallStack -> CallStack renderStack :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String whoCreated :: forall a. a -> GHC.Internal.Types.IO [GHC.Internal.Base.String] + withEmptyCallStack :: forall a. (HasCallStack => a) -> a withFrozenCallStack :: forall a. HasCallStack => (HasCallStack => a) -> a module GHC.Stack.CCS where ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -9265,6 +9265,7 @@ module GHC.Stack where pushCallStack :: ([GHC.Internal.Types.Char], SrcLoc) -> CallStack -> CallStack renderStack :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String whoCreated :: forall a. a -> GHC.Internal.Types.IO [GHC.Internal.Base.String] + withEmptyCallStack :: forall a. (HasCallStack => a) -> a withFrozenCallStack :: forall a. HasCallStack => (HasCallStack => a) -> a module GHC.Stack.CCS where ===================================== testsuite/tests/typecheck/should_compile/WarnDefaultedCallStack.hs ===================================== @@ -0,0 +1,44 @@ +{-# LANGUAGE ImplicitParams #-} +module WarnDefaultedCallStack where + +import GHC.Stack + +intCs :: HasCallStack => Int +intCs = 0 + +topLevelNoWarning :: HasCallStack => Int +topLevelNoWarning = intCs + +outerNoWarning :: HasCallStack => IO () +outerNoWarning = innerNoWarning (1000::Int) + where + innerNoWarning = \case + 0 -> error "inner" -- gets CallStack from outerNoWarning + n -> innerNoWarning $ n - 1 + +topLevelExplicitEmptyCallStackNoWarning :: IO () +topLevelExplicitEmptyCallStackNoWarning = withEmptyCallStack $ do + print $ intCs + localWarns + where + -- No enclosing CallStack, intCs warns. + localWarns = intCs + localNoWarning + + -- Implicit parameters of type CallStack also default. + implicitWarns :: CallStack + implicitWarns = ?other + + localNoWarning :: HasCallStack => Int + localNoWarning = intCs + nestedNoWarning + where + nestedNoWarning = intCs -- gets CallStack from localNoWarn + +topLevelWarns :: IO () +topLevelWarns = print intCs + +separateTopLevelWarns :: Int +separateTopLevelWarns = topLevelNoWarning + +withinDefUnderReports :: Int +withinDefUnderReports = + -- Only one warning reported here, the other absent due to a CSE'd wanted. + intCs + intCs ===================================== testsuite/tests/typecheck/should_compile/WarnDefaultedCallStack.stderr ===================================== @@ -0,0 +1,23 @@ +WarnDefaultedCallStack.hs:24:18: warning: [GHC-39361] [-Wdefaulted-callstack] + Defaulting to the empty call stack + arising from a use of ‘intCs’. + Add a ‘HasCallStack’ constraint to the enclosing definition to extend the call stack. + +WarnDefaultedCallStack.hs:28:21: warning: [GHC-39361] [-Wdefaulted-callstack] + Defaulting to the empty call stack + arising from a use of implicit parameter ‘?other’. + +WarnDefaultedCallStack.hs:36:23: warning: [GHC-39361] [-Wdefaulted-callstack] + Defaulting to the empty call stack + arising from a use of ‘intCs’. + Add a ‘HasCallStack’ constraint to the enclosing definition to extend the call stack. + +WarnDefaultedCallStack.hs:39:25: warning: [GHC-39361] [-Wdefaulted-callstack] + Defaulting to the empty call stack + arising from a use of ‘topLevelNoWarning’. + Add a ‘HasCallStack’ constraint to the enclosing definition to extend the call stack. + +WarnDefaultedCallStack.hs:44:3: warning: [GHC-39361] [-Wdefaulted-callstack] + Defaulting to the empty call stack + arising from a use of ‘intCs’. + Add a ‘HasCallStack’ constraint to the enclosing definition to extend the call stack. ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -926,6 +926,7 @@ test('T21206', normal, compile, ['']) test('T17594a', req_th, compile, ['']) test('T17594f', normal, compile, ['']) test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-context']) +test('WarnDefaultedCallStack', normal, compile, ['-Wdefaulted-callstack']) test('T24470b', normal, compile, ['']) test('T24566', [], makefile_test, []) test('T23764', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/815149f39fd18a353528cff2c61b5d7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/815149f39fd18a353528cff2c61b5d7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/spray-sudo-chown
by Cheng Shao (＠TerrorJack) 25 Jul '26

25 Jul '26

Cheng Shao deleted branch wip/spray-sudo-chown at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ci: Use shallow submodule clones by default
by Marge Bot (＠marge-bot) 25 Jul '26

25 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f586c885 by Simon Jakobi at 2026-07-24T18:05:00-04:00 ci: Use shallow submodule clones by default Limit submodule clones to depth one to reduce CI checkout costs. Keep fetching full submodule history for the submodule lint jobs, which inspect commits across a range. Assisted-by: gpt-5.6-sol via Codex CLI - - - - - 306120d2 by Duncan Coutts at 2026-07-24T18:05:43-04:00 Fix flaky test T3994 on FreeBSD On current FreeBSD versions, calling getpgid on a zombie process fails. In T3994, if we're really unlucky with delays and scheduling then we can end up in exactly that situation. Just catch that specific exception and ignore it. It's rare, and not our fault. - - - - - 7b116a0b by Cheng Shao at 2026-07-24T18:06:24-04:00 ci: add missing workaround for docker permissions in lint jobs Some lint jobs use ci-images with default user `ghc`, and the gitlab ci docker executor requires the `sudo chown` workaround to fix workspace directory permission issue. This patch adds the missing workarounds for the lint jobs. Fixes #27554. Co-authored-by: Codex <codex(a)openai.com> - - - - - 815149f3 by Andrzej Rybczak at 2026-07-25T15:06:43+00:00 Add -Wdefaulted-callstack Adds a new warning, -Wdefaulted-callstack, which warns when an implicit CallStack parameter is defaulted to the empty stack. In particular, this includes call sites where a function with a HasCallStack constraint is called from a definition that does *not* provide one. At such call sites the call stack is cut off and does not include the enclosing definition's callers, which can be a source of surprise if the user wants complete call stacks. Closes #27077. - - - - - 7171578b by Zubin Duggal at 2026-07-25T14:39:48-04:00 UniqueDFM: alter should preserve insertion order Before it always inserting new elements at the end. This is problematic because instances get inserted into the map with `alterF`, which can change ordering of how instances are printed with `:info` depending on the order in which we consult interfaces I expect `alter id k = id` and `alter (fmap f) k = adjust f k`. Moving keys to the end breaks that (`adjust` already preserves position). Fixes #27532 - - - - - 51 changed files: - .gitlab-ci.yml - + changelog.d/27532 - + changelog.d/warn-defaulted-callstack - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Unique/DFM.hs - docs/users_guide/using-warnings.rst - libraries/base/changelog.md - libraries/base/src/GHC/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - testsuite/tests/ghci/T16793/T16793.stdout - testsuite/tests/ghci/T18060/T18060.stdout - + testsuite/tests/ghci/T27532/Makefile - + testsuite/tests/ghci/T27532/T27532.stdout - + testsuite/tests/ghci/T27532/T27532j4.stdout - + testsuite/tests/ghci/T27532/a.script - + testsuite/tests/ghci/T27532/all.T - + testsuite/tests/ghci/T27532/b.script - + testsuite/tests/ghci/T27532/genT27532Modules - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/ghci/scripts/T8469.stdout - testsuite/tests/ghci/scripts/T8535.stdout - testsuite/tests/ghci/scripts/T9881.stdout - testsuite/tests/ghci/scripts/ghci020.stdout - testsuite/tests/ghci/scripts/ghci064.stdout - testsuite/tests/ghci/should_run/T10145.stdout - testsuite/tests/ghci/should_run/T18594.stdout - testsuite/tests/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/partial-sigs/should_compile/ExtraConstraints3.stderr - testsuite/tests/process/T3994.hs - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - + testsuite/tests/typecheck/should_compile/WarnDefaultedCallStack.hs - + testsuite/tests/typecheck/should_compile/WarnDefaultedCallStack.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T5300.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f0ae51115240364666e206842d44c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f0ae51115240364666e206842d44c1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/supersven/hadrian-cross-stage3] 5 commits: WIP cleanup
by Sven Tennie (＠supersven) 25 Jul '26

25 Jul '26

Sven Tennie pushed to branch wip/supersven/hadrian-cross-stage3 at Glasgow Haskell Compiler / GHC Commits: 323acc1a by GHC GitLab CI at 2026-07-25T07:52:51+02:00 WIP cleanup - - - - - b308f51a by GHC GitLab CI at 2026-07-25T08:48:21+02:00 WIP - - - - - ef1aa88d by GHC GitLab CI at 2026-07-25T09:14:18+02:00 formatting - - - - - 406a8862 by GHC GitLab CI at 2026-07-25T09:57:35+02:00 Simplify generateSettings - - - - - 57ca7ca3 by GHC GitLab CI at 2026-07-25T15:16:50+02:00 Simplify - - - - - 2 changed files: - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -253,9 +253,9 @@ buildBinDistDir root conf@BindistConfig{..} = do -- relocatable. The package DB is always at "package.conf.d" relative to -- the lib dir, matching the known bindist layout. let bindistSettings = bindistFilesDir -/- "lib" -/- "settings" - bindistContext = vanillaContext library_stage compiler + bindistContext = vanillaContext executable_stage compiler bindistSettingsContent <- interpretInContext bindistContext $ - generateSettings bindistSettings False "package.conf.d" executable_stage + generateSettings bindistSettings False "package.conf.d" library_stage writeFile' bindistSettings bindistSettingsContent copyDirectory rtsIncludeDir bindistFilesDir ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -252,32 +252,51 @@ generateRules = do (root -/- "ghc-stage2") <~+ ghcWrapper Stage2 (root -/- "ghc-stage3") <~+ ghcWrapper Stage3 - forM_ allStages $ \stage -> do - let prefix = root -/- stageString stage -/- "lib" - -- For the finalStage, we generate settings for that stage. For - -- others we look at the next stage. Why? Because cross-compilers - -- require libs from the successor stage, otherwise they are - -- compiled for the host and not the target. - stage' = if stage /= finalStage then succStage stage else stage - go gen file = generate file (semiEmptyTarget stage') gen + forM_ allStages $ \buildStage -> do + let -- Two stages are in play per rule iteration: + -- + -- * @buildStage@ — loop variable; the settings file is written + -- into @_build/<buildStage>/lib/settings@ and + -- describes the compiler at @compilerStage@. + -- * @compilerStage@ — the stage whose @bin/@ holds the compiler + -- the settings file describes; also the + -- ambient 'Expr' stage passed to + -- 'generateSettings' (via 'semiEmptyTarget'), + -- so it is the value of @executableStage@ + -- inside that function. + -- + -- For a cross-compiler the libs it links against live in the + -- /successor/ stage's lib dir; @libraryStage@ (computed in the + -- rule body below) is that successor. @compilerStage@ normally + -- equals @buildStage@, but at @finalStage@ there is no successor + -- to hold its libs, so @compilerStage@ drops to the predecessor + -- (the final stage's lib dir merely hosts the predecessor + -- cross-compiler's target-arch libs). + compilerStage = if buildStage == finalStage + then predStage buildStage + else buildStage + prefix = root -/- stageString buildStage -/- "lib" + go gen file = generate file (semiEmptyTarget compilerStage) gen (prefix -/- "settings") %> \out -> do - let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) - -- For cross, LibDir points to stage' lib dir, so pkgDb must also - -- be relative to stage' lib dir. - isCross <- crossStage stage - let libStage = case stage of + -- Stage0 has no library or package DB of its own (the + -- bootstrapping compiler uses Stage1's); for any other stage the + -- package DB lives where the LibDir redirect points (this stage's + -- own lib dir, or the successor's when @buildStage@ is a cross + -- stage). + isCross <- crossStage buildStage + let libraryStage = case buildStage of Stage0 {} -> Stage1 - _ -> if isCross then stage' else stage - pkgDb <- get_pkg_db libStage + _ -> if isCross then succStage buildStage else buildStage + pkgDb <- packageDbPath (PackageDbLoc libraryStage Final) -- addTrailingPathSeparator needed: makeRelativeNoSysLink uses -- splitPath where "lib" and "lib/" are distinct components. let libTopDir = addTrailingPathSeparator $ - if isCross - then root -/- stageString stage' -/- "lib" - else prefix + if isStage0 buildStage + then prefix + else root -/- stageString libraryStage -/- "lib" relPkgDb = makeRelativeNoSysLink libTopDir pkgDb - go (generateSettings out True relPkgDb (predStage stage')) out - (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr (targetStage (succStage stage))) out + go (generateSettings out True relPkgDb libraryStage) out + (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr (targetStage (succStage buildStage))) out where file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out @@ -557,42 +576,31 @@ ghcWrapper stage = do -- | Generate settings file, optionally including @LibDir@. -- +-- Describes the compiler whose stage is the ambient 'Expr' context +-- (available here as @executableStage@ via 'getStage'). The @libraryStage@ +-- argument is the stage whose lib dir holds the libraries the described +-- compiler links against — used both for the @base@ unit-id lookup and for +-- the @LibDir@ entry. It usually equals @executableStage@ but differs when +-- the compiler links against libraries from a different stage (cross +-- compilers, or the Stage0 bootstrap compiler using Stage1's libraries). +-- -- @rel_pkg_db@: package DB path relative to the lib dir (e.g. -- "package.conf.d"). Callers supply the correct relative path. For bindists --- the layout is known statically; for in-tree builds callers compute it. For --- bindists, we omit @LibDir@ so it defaults to @topDir@ at runtime. +-- the layout is known statically; for in-tree builds callers compute it. +-- For bindists, we omit @LibDir@ so it defaults to @topDir@ at runtime. generateSettings :: FilePath -> Bool -> FilePath -> Stage -> Expr String -generateSettings settingsFile includeLibDir rel_pkg_db compilerStage = do +generateSettings settingsFile includeLibDir rel_pkg_db libraryStage = do ctx <- getContext - stage <- getStage + executableStage <- getStage + + base_unit_id <- expr $ pkgUnitId libraryStage base - -- The unit-id of the base package which is always linked against (#25382). - -- For stage2 cross compilers the target libraries live in the stage3 lib - -- dir, so the base unit-id must come from stage2; for native stage2 the - -- libraries live in the stage1 lib dir. - base_unit_id <- expr $ do - case stage of - Stage0 {} -> error "Unable to generate settings for stage0" - Stage1 -> pkgUnitId Stage1 base - Stage2 -> do - isCross <- crossStage compilerStage - pkgUnitId (if isCross then stage else compilerStage) base - Stage3 -> pkgUnitId Stage2 base - - -- For cross compilers, LibDir points to the succeeding stage's lib dir - -- (which contains the target architecture's libraries). For non-cross, - -- it points to the preceding stage's lib dir as usual. - isCrossLibDir <- expr $ crossStage compilerStage - let stage_dir_stage = if isCrossLibDir then stage else compilerStage - - -- addTrailingPathSeparator is needed because makeRelativeNoSysLink uses - -- splitPath internally, where "lib" and "lib/" are distinct components. - lib_topDir :: FilePath <- expr $ addTrailingPathSeparator <$> stageLibPath stage_dir_stage + lib_topDir :: FilePath <- expr $ addTrailingPathSeparator <$> stageLibPath libraryStage let rel_lib_topDir = makeRelativeNoSysLink (dropFileName settingsFile) lib_topDir settings <- traverse sequence $ - [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit, Context.stage = compilerStage }))) - , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter compilerStage) + [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) + , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter executableStage) -- Hard-coded as Cabal queries these to determine way support and we -- need to always advertise all ways when bootstrapping. -- The settings file is generated at install time when installing a bindist. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ec8857ce2bfb35b175fa1f88da579… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ec8857ce2bfb35b175fa1f88da579… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] 2 commits: CmmLint: Check for unsupported MachOp widths
by Andreas Klebinger (＠AndreasK) 25 Jul '26

25 Jul '26

Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 71681e41 by Andreas Klebinger at 2026-07-25T11:51:29+00:00 CmmLint: Check for unsupported MachOp widths - - - - - 1523beef by Andreas Klebinger at 2026-07-25T11:52:30+00:00 Add tests - - - - - 7 changed files: - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/Cmm/Lint.hs ===================================== @@ -99,11 +99,11 @@ lintCmmExpr expr@(CmmMachOp op args) = do platform <- getPlatform tys <- mapM lintCmmExpr args lintShiftOp op (zip args tys) - let machop_arg_widths = machOpArgReps platform op + let machop_arg_widths_m = machOpArgReps platform op arg_tys = map (cmmExprType platform) args - if map typeWidth arg_tys == machop_arg_widths + if maybe False (\machop_arg_widths -> map typeWidth arg_tys == machop_arg_widths) machop_arg_widths_m then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr arg_tys machop_arg_widths + else cmmLintMachOpErr expr arg_tys machop_arg_widths_m lintCmmExpr (CmmRegOff reg offset) = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) @@ -279,8 +279,16 @@ addLintInfo info thing = CmmLint $ \platform -> Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> Maybe [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep Nothing + = do + platform <- getPlatform + cmmLintErr (text "in MachOp application: " $$ + nest 2 (pdoc platform expr) $$ + text "op is using unsupported width" $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintMachOpErr expr argsRep (Just opExpectsRep) = do platform <- getPlatform cmmLintErr (text "in MachOp application: " $$ ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -565,111 +565,118 @@ comparisonResultRep = bWord -- is it? -- application of a MachOp is "type-correct" by checking that the MachReps of -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. +-- We also check if the given width is supported at all. But there might be +-- false positives. -machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps :: Platform -> MachOp -> Maybe [Width] machOpArgReps platform op = case op of - MO_Add w -> [w,w] - MO_Sub w -> [w,w] - MO_Eq w -> [w,w] - MO_Ne w -> [w,w] - MO_Mul w -> [w,w] - MO_S_MulMayOflo w -> [w,w] - MO_S_Quot w -> [w,w] - MO_S_Rem w -> [w,w] - MO_S_Neg w -> [w] - MO_U_Quot w -> [w,w] - MO_U_Rem w -> [w,w] - - MO_S_Ge w -> [w,w] - MO_S_Le w -> [w,w] - MO_S_Gt w -> [w,w] - MO_S_Lt w -> [w,w] - - MO_U_Ge w -> [w,w] - MO_U_Le w -> [w,w] - MO_U_Gt w -> [w,w] - MO_U_Lt w -> [w,w] - - MO_F_Add w -> [w,w] - MO_F_Sub w -> [w,w] - MO_F_Mul w -> [w,w] - MO_F_Quot w -> [w,w] - MO_F_Neg w -> [w] - MO_F_Min w -> [w,w] - MO_F_Max w -> [w,w] - - MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] - - MO_F_Eq w -> [w,w] - MO_F_Ne w -> [w,w] - MO_F_Ge w -> [w,w] - MO_F_Le w -> [w,w] - MO_F_Gt w -> [w,w] - MO_F_Lt w -> [w,w] - - MO_And w -> [w,w] - MO_Or w -> [w,w] - MO_Xor w -> [w,w] - MO_Not w -> [w] - MO_Shl w -> [w, wordWidth platform] - MO_U_Shr w -> [w, wordWidth platform] - MO_S_Shr w -> [w, wordWidth platform] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_XX_Conv from _ -> [from] - MO_SF_Round from _ -> [from] - MO_FS_Truncate from _ -> [from] - MO_FF_Conv from _ -> [from] - MO_WF_Bitcast w -> [w] - MO_FW_Bitcast w -> [w] - - MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - - MO_V_Broadcast _ w -> [w] - MO_V_Insert l w -> [vecwidth l w, w, W32] - MO_V_Extract l w -> [vecwidth l w, W32] - MO_VF_Broadcast _ w -> [w] - MO_VF_Insert l w -> [vecwidth l w, w, W32] - MO_VF_Extract l w -> [vecwidth l w, W32] + MO_Add w -> Just [w,w] + MO_Sub w -> Just [w,w] + MO_Eq w -> Just [w,w] + MO_Ne w -> Just [w,w] + MO_Mul w -> Just [w,w] + MO_S_MulMayOflo w -> Just [w,w] + MO_S_Quot w -> Just [w,w] + MO_S_Rem w -> Just [w,w] + MO_S_Neg w -> Just [w] + MO_U_Quot w -> Just [w,w] + MO_U_Rem w -> Just [w,w] + + MO_S_Ge w -> Just [w,w] + MO_S_Le w -> Just [w,w] + MO_S_Gt w -> Just [w,w] + MO_S_Lt w -> Just [w,w] + + MO_U_Ge w -> Just [w,w] + MO_U_Le w -> Just [w,w] + MO_U_Gt w -> Just [w,w] + MO_U_Lt w -> Just [w,w] + + MO_F_Add w -> Just [w,w] + MO_F_Sub w -> Just [w,w] + MO_F_Mul w -> Just [w,w] + MO_F_Quot w -> Just [w,w] + MO_F_Neg w -> Just [w] + MO_F_Min w -> Just [w,w] + MO_F_Max w -> Just [w,w] + + MO_FMA _ l w -> Just [vecwidth l w, vecwidth l w, vecwidth l w] + + MO_F_Eq w -> Just [w,w] + MO_F_Ne w -> Just [w,w] + MO_F_Ge w -> Just [w,w] + MO_F_Le w -> Just [w,w] + MO_F_Gt w -> Just [w,w] + MO_F_Lt w -> Just [w,w] + + MO_And w -> Just [w,w] + MO_Or w -> Just [w,w] + MO_Xor w -> Just [w,w] + MO_Not w -> Just [w] + MO_Shl w -> Just [w, wordWidth platform] + MO_U_Shr w -> Just [w, wordWidth platform] + MO_S_Shr w -> Just [w, wordWidth platform] + + MO_SS_Conv from _ -> Just [from] + MO_UU_Conv from _ -> Just [from] + MO_XX_Conv from _ -> Just [from] + -- Only supports W32/W64 + MO_SF_Round from _w -> onlyW32W64 from + MO_FS_Truncate from _ -> onlyW32W64 from + MO_FF_Conv from _ -> onlyW32W64 from + MO_WF_Bitcast w -> onlyW32W64 w + MO_FW_Bitcast w -> onlyW32W64 w + + MO_V_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + MO_VF_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + + MO_V_Broadcast _ w -> Just [w] + MO_V_Insert l w -> Just [vecwidth l w, w, W32] + MO_V_Extract l w -> Just [vecwidth l w, W32] + MO_VF_Broadcast _ w -> Just [w] + MO_VF_Insert l w -> Just [vecwidth l w, w, W32] + MO_VF_Extract l w -> Just [vecwidth l w, W32] -- SIMD vector indices are always 32 bit - MO_V_Add l w -> [vecwidth l w, vecwidth l w] - MO_V_Sub l w -> [vecwidth l w, vecwidth l w] - MO_V_Mul l w -> [vecwidth l w, vecwidth l w] + MO_V_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Mul l w -> Just [vecwidth l w, vecwidth l w] - MO_VS_Neg l w -> [vecwidth l w] - MO_VS_Abs l w -> [vecwidth l w] - MO_VS_Min l w -> [vecwidth l w, vecwidth l w] - MO_VS_Max l w -> [vecwidth l w, vecwidth l w] + MO_VS_Neg l w -> Just [vecwidth l w] + MO_VS_Abs l w -> Just [vecwidth l w] + MO_VS_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VS_Max l w -> Just [vecwidth l w, vecwidth l w] - MO_VU_Min l w -> [vecwidth l w, vecwidth l w] - MO_VU_Max l w -> [vecwidth l w, vecwidth l w] + MO_VU_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VU_Max l w -> Just [vecwidth l w, vecwidth l w] -- NOTE: The below is owing to the fact that floats use the SSE registers - MO_VF_Add l w -> [vecwidth l w, vecwidth l w] - MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] - MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] - MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] - MO_VF_Neg l w -> [vecwidth l w] - MO_VF_Abs l w -> [vecwidth l w] - MO_VF_Sqrt l w -> [vecwidth l w] - MO_VF_Min l w -> [vecwidth l w, vecwidth l w] - MO_VF_Max l w -> [vecwidth l w, vecwidth l w] - - MO_V_And l w -> [vecwidth l w, vecwidth l w] - MO_V_Or l w -> [vecwidth l w, vecwidth l w] - MO_V_Xor l w -> [vecwidth l w, vecwidth l w] - MO_VF_And l w -> [vecwidth l w, vecwidth l w] - MO_VF_Or l w -> [vecwidth l w, vecwidth l w] - MO_VF_Xor l w -> [vecwidth l w, vecwidth l w] - - MO_RelaxedRead _ -> [wordWidth platform] - MO_AlignmentCheck _ w -> [w] + MO_VF_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> Just [vecwidth l w] + MO_VF_Abs l w -> Just [vecwidth l w] + MO_VF_Sqrt l w -> Just [vecwidth l w] + MO_VF_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Max l w -> Just [vecwidth l w, vecwidth l w] + + MO_V_And l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Xor l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_And l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Xor l w -> Just [vecwidth l w, vecwidth l w] + + MO_RelaxedRead _ -> Just [wordWidth platform] + MO_AlignmentCheck _ w -> Just [w] where vecwidth l w = widthFromBytes (l * widthInBytes w) + onlyW32W64 w + | w == W64 = Just [w] + | w == W32 = Just [w] + | otherwise = Nothing ----------------------------------------------------------------------------- -- CallishMachOp ===================================== testsuite/tests/codeGen/should_run/T27537.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE lt8 #-} +lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1 +lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eq8 #-} +eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1 +eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eqi16 #-} +eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1 +eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n)))) + +{-# NOINLINE rem8 #-} +rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54 +rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))) + +main :: IO () +main = do + print (lt8 (-2) 255) + print (eq8 (-2) 254) + print (eqi16 (-2) 65534) + print (rem8 (-2) 100) ===================================== testsuite/tests/codeGen/should_run/T27537.stdout ===================================== @@ -0,0 +1,4 @@ +1 +1 +1 +54 ===================================== testsuite/tests/codeGen/should_run/T27538.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE ix #-} +ix :: Int +ix = 0 + +{-# NOINLINE f #-} +f :: Int8# -> Int# +f x = if isTrue# (x `ltInt8#` intToInt8# 0#) + then (int8ToWord8# x) `gtWord8#` wordToWord8# 200## + else 1# + +main :: IO () +main = do + let !(I# i) = ix + x = indexInt8OffAddr# "\x80"# i + putStrLn ("f(0x80) = " ++ show (I# (f x))) ===================================== testsuite/tests/codeGen/should_run/T27538.stdout ===================================== @@ -0,0 +1 @@ +f(0x80) = 0 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -297,3 +297,7 @@ test('aarch64-sxtw-run', ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O']) test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) + +test('T27537', normal, compile_and_run, ['-O']) + +test('T27538', normal, compile_and_run, ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fefaf5f34da5c723b8dce977710a5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fefaf5f34da5c723b8dce977710a5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] 4 commits: cmm: Add machop width info with -dppr-debug for infix ops.
by Andreas Klebinger (＠AndreasK) 25 Jul '26

25 Jul '26

Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 16046e69 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 cmm: Add machop width info with -dppr-debug for infix ops. - - - - - 13f7d159 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 Add test for #27430. - - - - - 28318419 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 arm64 ncg: Fix subword handling of ffi calls. Our invariants require us to clear the high bits for subword results. We now do so both for unspecified bit casts (MO_CONV_XX) and when taking in results from ffi calls. I also renamed truncateReg to make it clear it changes the register. - - - - - 7fefaf5f by Andreas Klebinger at 2026-07-25T11:19:30+00:00 Fix truncateReg - - - - - 8 changed files: - + changelog.d/T27430 - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - + testsuite/tests/codeGen/should_run/T27430.hs - + testsuite/tests/codeGen/should_run/T27430.stdout - + testsuite/tests/codeGen/should_run/T27430_c.c - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== changelog.d/T27430 ===================================== @@ -0,0 +1,11 @@ +section: compiler +issues: #27430 +mrs: !16255 +synopsis: + AArch64 code generation: Fix handling of subword return values at FFI boundary. +description: + When calling C functions returning subword values, sometimes those values high + bit would incorrectly influence certain operations. + + We now zero the high bits consistently to avoid this. + ===================================== compiler/GHC/Cmm/Expr.hs ===================================== @@ -443,6 +443,11 @@ pprExpr platform e CmmLit lit -> pprLit platform lit _other -> pprExpr1 platform e +-- `exp` usually, but (expr[width]) with -dppr-debug +withDebugWidth :: Width -> SDoc -> SDoc +withDebugWidth w exp = + ifPprDebug (parens (exp <> brackets (ppr w))) exp + -- Here's the precedence table from GHC.Cmm.Parser: -- %nonassoc '>=' '>' '<=' '<' '!=' '==' -- %left '|' @@ -465,15 +470,17 @@ pprExpr1 platform e = pprExpr7 platform e infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing +infixMachOp1 mop = case mop of + (MO_Eq w) -> Just $ withDebugWidth w (text "==") + (MO_Ne w) -> Just $ withDebugWidth w (text "!=") + (MO_Shl w) -> Just $ withDebugWidth w (text "<<") + (MO_U_Shr w) -> Just $ withDebugWidth w (text ">>") + (MO_U_Ge w) -> Just $ withDebugWidth w (text ">=") + (MO_U_Le w) -> Just $ withDebugWidth w (text "<=") + (MO_U_Gt w) -> Just $ withDebugWidth w (char '>') + (MO_U_Lt w) -> Just $ withDebugWidth w (char '<') + _ -> Nothing + where -- %left '-' '+' pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 @@ -483,8 +490,8 @@ pprExpr7 platform (CmmMachOp op [x,y]) = pprExpr7 platform x <+> doc <+> pprExpr8 platform y pprExpr7 platform e = pprExpr8 platform e -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 (MO_Add w) = Just $ withDebugWidth w (char '+') +infixMachOp7 (MO_Sub w) = Just $ withDebugWidth w (char '-') infixMachOp7 _ = Nothing -- %left '/' '*' '%' @@ -493,9 +500,9 @@ pprExpr8 platform (CmmMachOp op [x,y]) = pprExpr8 platform x <+> doc <+> pprExpr9 platform y pprExpr8 platform e = pprExpr9 platform e -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 (MO_U_Quot w) = Just $ withDebugWidth w (char '/') +infixMachOp8 (MO_Mul w) = Just $ withDebugWidth w (char '*') +infixMachOp8 (MO_U_Rem w) = Just $ withDebugWidth w (char '%') infixMachOp8 _ = Nothing pprExpr9 :: Platform -> CmmExpr -> SDoc ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -142,7 +142,7 @@ data MachOp -- Conversions. Some of these will be NOPs. -- Floating-point conversions use the signed variant. - | MO_SF_Round Width Width -- Signed int -> Float + | MO_SF_Round Width Width -- Signed int -> Float, but only W32/W64 inputs | MO_FS_Truncate Width Width -- Float -> Signed int | MO_SS_Conv Width Width -- Signed int -> Signed int | MO_UU_Conv Width Width -- unsigned int -> unsigned int ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -358,19 +358,13 @@ data Register = Fixed Format Reg InstrBlock | Any Format (Reg -> InstrBlock) --- | Sometimes we need to change the Format of a register. Primarily during --- conversion. -swizzleRegisterRep :: Format -> Register -> Register -swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code -swizzleRegisterRep format (Any _ codefn) = Any format codefn - -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _ty)) = case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) @@ -662,7 +656,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) -- in between operations. -- -- IMPORTANT: this invariant only holds within a single expression tree as --- generated by the NCG (via truncateReg after each sub-word operation). It +-- generated by the NCG (via truncateSubwordRegInplace after each sub-word operation). It -- does NOT hold at function entry points or across basic block boundaries, -- because the GHC calling convention does not guarantee that callers -- zero-extend sub-word arguments. Therefore, any operation that is sensitive @@ -688,7 +682,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) -- Next we compute `c`: The `%not` requires no extension of its operands, but -- we must still truncate the result back down to 8-bits. Finally the `%shrl` -- requires no extension and no truncate since we can assume that --- `c` is zero-extended (it was produced by a truncateReg in the same block). +-- `c` is zero-extended (it was produced by a truncateSubwordRegInplace in the same block). -- -- TODO: -- Don't use Width in Operands @@ -931,7 +925,7 @@ getRegister' config plat expr let w' = opRegWidth w in code `snocOL` MVN (OpReg w' dst) (OpReg w' reg) `appOL` - truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] + truncateSubwordRegInplace w dst -- See Note [Signed arithmetic on AArch64] MO_S_Neg w -> negate code w reg MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg)) @@ -952,7 +946,13 @@ getRegister' config plat expr where fmt = intFormat w -- Conversions - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + MO_XX_Conv from to + | to >= W32 || to > from -> + -- We don't care about garbage high bits when upcasting this way. + pure $ Fixed (intFormat to) reg code + | otherwise -> do + (trunc_reg, code_trunc) <- truncateSubwordReg to reg + return $ Fixed (intFormat to) trunc_reg (code `appOL` code_trunc) -- Vector MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg)) @@ -1064,7 +1064,7 @@ getRegister' config plat expr code `appOL` code_sx `snocOL` NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL` - truncateReg w' w dst + truncateSubwordRegInplace w dst ss_conv from to reg code = let w' = opRegWidth (max from to) @@ -1073,7 +1073,7 @@ getRegister' config plat expr SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL` -- At this point an 8- or 16-bit value would be sign-extended -- to 32-bits. Truncate back down the final width. - truncateReg w' to dst + truncateSubwordRegInplace to dst -- Dyadic machops: -- @@ -1220,7 +1220,7 @@ getRegister' config plat expr code_y `appOL` op (OpReg w dst) (OpReg w reg_x) op_y) - -- A (potentially signed) integer operation. + -- A (potentially signed) integer operation that can have immediate arguments. -- In the case of 8- and 16-bit signed arithmetic we must first -- sign-extend both arguments to 32-bits. -- See Note [Signed arithmetic on AArch64]. @@ -1230,6 +1230,7 @@ getRegister' config plat expr -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o> + let w' = opRegWidth w (reg_x, format_x, code_x) <- getSomeReg x (op_y, format_y, code_y) <- case y of CmmLit (CmmInt n w) @@ -1241,12 +1242,11 @@ getRegister' config plat expr massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" -- This is the width of the registers on which the operation -- should be performed. - let w' = opRegWidth w return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + truncateSubwordRegInplace w dst -- truncate back to the operand's original width -- A (potentially signed) integer operation. -- In the case of 8- and 16-bit signed arithmetic we must first @@ -1263,7 +1263,8 @@ getRegister' config plat expr -- should be performed. let w' = opRegWidth w signExt r - | not is_signed = return (r, nilOL) + -- See Note [Signed arithmetic on AArch64] and #27430 + | not is_signed = truncateSubwordReg w' r | otherwise = signExtendReg w w' r (reg_x_sx, code_x_sx) <- signExt reg_x (reg_y_sx, code_y_sx) <- signExt reg_y @@ -1274,7 +1275,7 @@ getRegister' config plat expr code_x_sx `appOL` code_y_sx `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + truncateSubwordRegInplace w dst -- truncate back to the operand's original width floatOp w op = do (reg_fx, format_x, code_fx) <- getFloatReg x @@ -1897,25 +1898,44 @@ signExtendReg w w' r = | otherwise -> extend SXTW W16 -> extend SXTH W8 -> extend SXTB - _ -> panic "intOp" + _ -> panic "signExtendReg:unexpectedWidth" where noop = return (r, nilOL) extend instr = do r' <- getNewRegNat (intFormat w') return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) --- | Instructions to truncate the value in the given register from width @w@ --- down to width @w'@. -truncateReg :: Width -> Width -> Reg -> OrdList Instr -truncateReg w w' r = - case w of +-- | Truncate/zero extend the subwords high bits and store the +-- result in a new register. +truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr) +truncateSubwordReg w_to r = do + case w_to of + -- Simply move it unchanged, we use at least 32bits + W64 -> trunc W64 MOV -- Ensure W64->W64 is a no-op by using 64bit mov. + W32 -> trunc W32 MOV + + -- Actual truncation + W16 -> trunc W32 UXTH + W8 -> trunc W32 UXTB + _ -> panic "truncateSubwordReg:unexpectedWidth" + where + trunc w instr = do + r' <- getNewRegNat (intFormat w_to) + return (r', unitOL $ instr (OpReg w r') (OpReg w r)) + +-- | Like @truncateSubwordReg@, but modifes the argument register in place if we +-- need to truncate. +truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr +truncateSubwordRegInplace w_to r = do + case w_to of W64 -> nilOL - W32 - | w' == W32 -> nilOL - _ -> unitOL $ UBFM (OpReg w r) - (OpReg w r) - (OpImm (ImmInt 0)) - (OpImm $ ImmInt $ widthInBits w' - 1) + W32 -> nilOL + W16 -> trunc UXTH + W8 -> trunc UXTB + _ -> panic "truncateSubwordReg:unexpectedWidth" + where + trunc instr = do + unitOL $ instr (OpReg W32 r) (OpReg W32 r) -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -2352,7 +2372,7 @@ genCCall target dest_regs arg_regs = do -- product, and hi gets the overflow (sign extension bits). SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL` ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` - truncateReg w' w lo `snocOL` + truncateSubwordRegInplace w lo `snocOL` -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'. -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive. -- No overflow iff hi is the sign extension of lo: @@ -2362,7 +2382,7 @@ genCCall target dest_regs arg_regs = do -- NE to set nd = 1 when overflow occurred. CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` CSET (OpReg w' nd) NE `appOL` - truncateReg w' w hi + truncateSubwordRegInplace w hi -- Can't handle > 64 bit operands | otherwise -> unsupported (MO_S_Mul2 w) PrimTarget (MO_U_Mul2 w) @@ -2412,7 +2432,7 @@ genCCall target dest_regs arg_regs = do (OpImm (ImmInt $ widthInBits w)) -- lsb (OpImm (ImmInt $ widthInBits w)) -- width to extract `appOL` - truncateReg W64 w lo + truncateSubwordRegInplace w lo ) | otherwise -> unsupported (MO_U_Mul2 w) PrimTarget (MO_Clz w) @@ -2898,6 +2918,7 @@ genCCall target dest_regs arg_regs = do passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + -- readResults gpArgs fpArgs dest_regs reg_acc code_acc readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock) readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do @@ -2915,7 +2936,14 @@ genCCall target dest_regs arg_regs = do r_dst = getRegisterReg platform (CmmLocal dst) if isFloatFormat format || isVecFormat format then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) - else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)) + else do + -- See [Signed arithmetic on AArch64] + -- Strictly speaking we don't have to here but err on the side of caution. + let !mov_instr = case w of + W8 -> UXTB + W16 -> UXTH + _ -> MOV + readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg)) unaryFloatOp w op arg_reg dest_reg = do platform <- getPlatform ===================================== testsuite/tests/codeGen/should_run/T27430.hs ===================================== @@ -0,0 +1,44 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Data.Bits +import GHC.Word + +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8 +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word16 +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word32 + +x :: Word64 +x = 5 + +-- Those should give just x when truncated. +y8,y16,y32 :: Word64 +y8 = setBit x 8 +y16 = setBit x 16 +y32 = setBit x 32 + +eq8 :: Word8 -> Word8 -> Int +eq8 (W8# a) (W8# b) = I# (eqWord8# a b) + +eq16 :: Word16 -> Word16 -> Int +eq16 (W16# a) (W16# b) = I# (eqWord16# a b) + +eq32 :: Word32 -> Word32 -> Int +eq32 (W32# a) (W32# b) = I# (eqWord32# a b) + +{-# NOINLINE outline_eq8 #-} +outline_eq8 = eq8 +{-# NOINLINE outline_eq16 #-} +outline_eq16 = eq16 +{-# NOINLINE outline_eq32 #-} +outline_eq32 = eq32 + +main :: IO () +main = do + print (eq8 (u64_to_u8 x) (u64_to_u8 y8)) + print (eq16 (u64_to_u16 x) (u64_to_u16 y16)) + print (eq32 (u64_to_u32 x) (u64_to_u32 y32)) + + print (outline_eq8 (u64_to_u8 x) (u64_to_u8 y8)) + print (outline_eq16 (u64_to_u16 x) (u64_to_u16 y16)) + print (outline_eq32 (u64_to_u32 x) (u64_to_u32 y32)) ===================================== testsuite/tests/codeGen/should_run/T27430.stdout ===================================== @@ -0,0 +1,6 @@ +1 +1 +1 +1 +1 +1 ===================================== testsuite/tests/codeGen/should_run/T27430_c.c ===================================== @@ -0,0 +1,5 @@ +#include <stdint.h> + +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; } +uint8_t u64_to_u16(uint64_t v) { return (uint16_t)v; } +uint8_t u64_to_u32(uint64_t v) { return (uint32_t)v; } ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -295,3 +295,5 @@ test('aarch64-sxtw-run', when(unregisterised(), skip)], multi_compile_and_run, ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O']) + +test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b2345656cb37458a6a4753437329… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b2345656cb37458a6a4753437329… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fix-cmm-dump-labels] 4 commits: ci: Use shallow submodule clones by default
by Cheng Shao (＠TerrorJack) 25 Jul '26

25 Jul '26

Cheng Shao pushed to branch wip/fix-cmm-dump-labels at Glasgow Haskell Compiler / GHC Commits: f586c885 by Simon Jakobi at 2026-07-24T18:05:00-04:00 ci: Use shallow submodule clones by default Limit submodule clones to depth one to reduce CI checkout costs. Keep fetching full submodule history for the submodule lint jobs, which inspect commits across a range. Assisted-by: gpt-5.6-sol via Codex CLI - - - - - 306120d2 by Duncan Coutts at 2026-07-24T18:05:43-04:00 Fix flaky test T3994 on FreeBSD On current FreeBSD versions, calling getpgid on a zombie process fails. In T3994, if we're really unlucky with delays and scheduling then we can end up in exactly that situation. Just catch that specific exception and ignore it. It's rare, and not our fault. - - - - - 7b116a0b by Cheng Shao at 2026-07-24T18:06:24-04:00 ci: add missing workaround for docker permissions in lint jobs Some lint jobs use ci-images with default user `ghc`, and the gitlab ci docker executor requires the `sudo chown` workaround to fix workspace directory permission issue. This patch adds the missing workarounds for the lint jobs. Fixes #27554. Co-authored-by: Codex <codex(a)openai.com> - - - - - 27fc2f8a by Cheng Shao at 2026-07-25T11:20:53+02:00 compiler: fix missing top-level procedure labels in cmm dumps This patch fixes missing top-level procedure labels in some intermediate Cmm pass dumps. Fixes #27553. Co-authored-by: Codex <codex(a)openai.com> - - - - - 4 changed files: - .gitlab-ci.yml - + changelog.d/fix-cmm-dump-labels - compiler/GHC/Cmm/Pipeline.hs - testsuite/tests/process/T3994.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -23,6 +23,10 @@ variables: # Always start with a fresh clone to avoid non-hermetic builds GIT_STRATEGY: clone + # Shallow submodule clones. Overridden by individual jobs that need deeper + # submodule history. + GIT_SUBMODULE_DEPTH: 1 + # Overridden by individual jobs CONFIGURE_ARGS: "" @@ -262,7 +266,8 @@ lint-changelog: GIT_SUBMODULE_STRATEGY: none before_script: - export PATH="/opt/toolchain/bin:$PATH" - - git config --global --add safe.directory "$CI_PROJECT_DIR" + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - .gitlab/ci.sh lint_changelog dependencies: [] @@ -279,6 +284,9 @@ lint-linters: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - mypy testsuite/tests/linters/regex-linters/*.py dependencies: [] @@ -290,6 +298,9 @@ lint-testsuite: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - make -Ctestsuite list_broken TEST_HC=$GHC dependencies: [] @@ -301,6 +312,9 @@ typecheck-testsuite: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - mypy testsuite/driver/runtests.py dependencies: [] @@ -313,6 +327,7 @@ typecheck-testsuite: extends: .lint-params variables: BUILD_FLAVOUR: default + GIT_SUBMODULE_DEPTH: 0 # full history script: - .gitlab/ci.sh configure - .gitlab/ci.sh run_hadrian stage0:exe:lint-submodule-refs @@ -330,6 +345,9 @@ lint-author: extends: .lint variables: GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" ===================================== changelog.d/fix-cmm-dump-labels ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Fix missing top-level procedure labels in some intermediate Cmm pass dumps. +issues: #27553 +mrs: !16406 ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -8,6 +8,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Cmm +import GHC.Cmm.CLabel import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt import GHC.Cmm.CommonBlockElim @@ -80,14 +81,14 @@ cpsTop logger platform cfg dus proc = -- CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOptsProc splitting_proc_points proc - dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g + dump l Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g let !TopInfo {stack_info=StackInfo { arg_space = entry_off , do_layout = do_layout }} = h ----------- Eliminate common blocks ------------------------------------- g <- {-# SCC "elimCommonBlocks" #-} - condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g + condPass l (cmmOptElimCommonBlks cfg) elimCommonBlocks g Opt_D_dump_cmm_cbe "Post common block elimination" -- Any work storing block Labels must be performed _after_ @@ -98,7 +99,7 @@ cpsTop logger platform cfg dus proc = then {-# SCC "createSwitchPlans" #-} pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g else pure (g, dus) - dump Opt_D_dump_cmm_switch "Post switch plan" g + dump l Opt_D_dump_cmm_switch "Post switch plan" g ----------- ThreadSanitizer instrumentation ----------------------------- g <- {-# SCC "annotateTSAN" #-} @@ -111,7 +112,7 @@ cpsTop logger platform cfg dus proc = return $ initUs_ us $ annotateTSAN platform g else return g - dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g + dump l Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g ----------- Proc points ------------------------------------------------- let @@ -134,11 +135,11 @@ cpsTop logger platform cfg dus proc = if do_layout then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g else ((g, mapEmpty), dus) - dump Opt_D_dump_cmm_sp "Layout Stack" g + dump l Opt_D_dump_cmm_sp "Layout Stack" g ----------- Sink and inline assignments -------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass (cmmOptSink cfg) (cmmSink platform) g + condPass l (cmmOptSink cfg) (cmmSink platform) g Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ---------------------------------------------- @@ -182,11 +183,11 @@ cpsTop logger platform cfg dus proc = dumps flag name = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) - condPass do_opt pass g dumpflag dumpname = + condPass lbl do_opt pass g dumpflag dumpname = if do_opt then do g <- return $ pass g - dump dumpflag dumpname g + dump lbl dumpflag dumpname g return g else return g @@ -359,10 +360,10 @@ generator later. -} -dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph logger platform do_linting flag name g = do +dumpGraph :: Logger -> Platform -> Bool -> CLabel -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger platform do_linting lbl flag name g = do when do_linting $ do_lint g - dumpWith logger flag name FormatCMM (pdoc platform g) + dumpWith logger flag name FormatCMM (pdoc platform lbl $$ pdoc platform g) where do_lint g = case cmmLintGraph platform g of Just err -> do { fatalErrorMsg logger err ===================================== testsuite/tests/process/T3994.hs ===================================== @@ -1,7 +1,10 @@ module Main where import Control.Concurrent +import Control.Exception +import Control.Monad import System.IO +import System.IO.Error import System.Process main :: IO () @@ -9,14 +12,24 @@ main = do (_,Just hout,_,p) <- createProcess (proc "./T3994app" ["start", "10000 { std_out = CreatePipe, create_group = True } start <- hGetLine hout putStrLn start - interruptProcessGroupOf p - t <- myThreadId - -- timeout - forkIO $ do - threadDelay 5000000 - putStrLn "Interrupting a Running Process Failed" - hFlush stdout - killThread t - waitForProcess p + + -- On FreeBSD if we're _really_ unlucky with scheduling, then the + -- call to interruptProcessGroupOf can fail due to the process + -- having already terminated (despite it running for at least 10ms!) + -- If so, we just skip doing anything rather than fail the test, + -- since this isn't our fault and is rare and scheduling dependent. + -- See #27512 and https://reviews.freebsd.org/D58393 + handleJust (guard . isDoesNotExistError) (\_ -> return ()) $ do + interruptProcessGroupOf p + t <- myThreadId + -- timeout + forkIO $ do + threadDelay 5000000 + putStrLn "Interrupting a Running Process Failed" + hFlush stdout + killThread t + waitForProcess p + return () + putStrLn "end" return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/547a7494b077c513190750d7f2ee90… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/547a7494b077c513190750d7f2ee90… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/27532] UniqueDFM: alter should preserve insertion order
by Zubin (＠wz1000) 25 Jul '26

25 Jul '26

Zubin pushed to branch wip/27532 at Glasgow Haskell Compiler / GHC Commits: aa074c95 by Zubin Duggal at 2026-07-25T10:38:55+05:30 UniqueDFM: alter should preserve insertion order Before it always inserting new elements at the end. This is problematic because instances get inserted into the map with `alterF`, which can change ordering of how instances are printed with `:info` depending on the order in which we consult interfaces I expect `alter id k = id` and `alter (fmap f) k = adjust f k`. Moving keys to the end breaks that (`adjust` already preserves position). Fixes #27532 - - - - - 28 changed files: - + changelog.d/27532 - compiler/GHC/Types/Unique/DFM.hs - testsuite/tests/ghci/T16793/T16793.stdout - testsuite/tests/ghci/T18060/T18060.stdout - + testsuite/tests/ghci/T27532/Makefile - + testsuite/tests/ghci/T27532/T27532.stdout - + testsuite/tests/ghci/T27532/T27532j4.stdout - + testsuite/tests/ghci/T27532/a.script - + testsuite/tests/ghci/T27532/all.T - + testsuite/tests/ghci/T27532/b.script - + testsuite/tests/ghci/T27532/genT27532Modules - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/ghci/scripts/T8469.stdout - testsuite/tests/ghci/scripts/T8535.stdout - testsuite/tests/ghci/scripts/T9881.stdout - testsuite/tests/ghci/scripts/ghci020.stdout - testsuite/tests/ghci/scripts/ghci064.stdout - testsuite/tests/ghci/should_run/T10145.stdout - testsuite/tests/ghci/should_run/T18594.stdout - testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_fail/T5300.stderr Changes: ===================================== changelog.d/27532 ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Make instance ordering in :info output stable +description: + Updating an existing key in a UniqDFM no longer moves it to the end of the + iteration order. Previously the order of instances printed by :info depended + on the order in which interfaces were loaded, so it could change after + unrelated imports and differ between compiler builds. +mrs: !16385 +issues: #27532 ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -91,6 +91,11 @@ import qualified GHC.Data.Word64Set as W -- If the client of the map performs operations on the map in deterministic -- order then `udfmToList` returns them in deterministic order. -- +-- The order does not depend on how existing entries were +-- updated. Updating an existing entry keeps it original position in the order +-- This means `alterUDFM` consistent with `addToUDFM` and `adjustUDFM`, +-- so that for example `alterUDFM id k = id` and `alterUDFM (fmap f) k = adjustUDFM f k` +-- -- There is an implementation cost: each element is given a serial number -- as it is added, and `udfmToList` sorts its result by this serial -- number. So you should only use `UniqDFM` if you need the deterministic @@ -110,6 +115,14 @@ import qualified GHC.Data.Word64Set as W -- every value with the insertion time that can later be used to sort the -- values when asked to convert to a list. -- +-- Updating an existing key keeps the old tag. This keeps the order stable for +-- maps whose entries are updated many times. The instance environments are +-- the main example: inserting an instance updates the entry of its class in a +-- DNameEnv, and when updates moved keys to the end the order of instances shown +-- by :info depended on the order in which interfaces happened to be loaded +-- (#27532). Now a class keeps its place once its first instance is added, so +-- loading further interfaces cannot change the order. +-- -- An alternative would be to have -- -- data UniqDFM ele = UDFM (M.IntMap ele) [ele] @@ -169,11 +182,13 @@ emptyUDFM = UDFM M.empty 0 unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 --- The new binding always goes to the right of existing ones +-- A new key goes to the right of existing ones +-- Overwriting an existing key keeps its position in the iteration order addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt addToUDFM m k v = addToUDFM_Directly m (getUnique k) v --- The new binding always goes to the right of existing ones +-- A new key goes to the right of existing ones +-- Overwriting an existing key keeps its position in the iteration order addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) @@ -435,7 +450,8 @@ adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i -- | The expression (@'alterUDFM' f map k@) alters value x at k, or absence -- thereof. 'alterUDFM' can be used to insert, delete, or update a value in -- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. +-- more efficient. Updating an existing key keeps its position in the +-- deterministic iteration order. -- -- 'alterUDFM' is non-strict in @k@. alterUDFM @@ -447,16 +463,16 @@ alterUDFM alterUDFM f (UDFM m i) k = UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) where - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i + alterf Nothing = inject i $ f Nothing + alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v) + inject _ Nothing = Nothing + inject tag (Just v) = Just $ TaggedVal v tag -- | The expression (@'upsertUDFM' f map k@) updates the value at @k@ or inserts -- a new value if @k@ is absent. -- --- Like 'alterUDFM', updating an existing entry assigns it the current tag, so it --- becomes the newest element in deterministic iteration order. +-- Updating an existing entry keeps its original tag, so its position in +-- deterministic iteration order is unchanged and does not depend on update order. upsertUDFM :: Uniquable key => (Maybe elt -> elt) -- ^ How to adjust the element @@ -467,13 +483,14 @@ upsertUDFM f (UDFM m i) k = UDFM (MS.upsert upsertf (getKey $ getUnique k) m) (i + 1) where upsertf Nothing = TaggedVal (f Nothing) i - upsertf (Just (TaggedVal v _)) = TaggedVal (f (Just v)) i + upsertf (Just (TaggedVal v old_i)) = TaggedVal (f (Just v)) old_i -- | The expression (@'alterUDFM_L' f map k@) alters value @x@ at @k@, or absence -- thereof and returns the new element at @k@ if there is any. -- 'alterUDFM_L' can be used to insert, delete, or update a value in -- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. +-- more efficient. Updating an existing key keeps its position in the +-- deterministic iteration order. -- -- Note, 'alterUDFM_L' is strict in @k@. alterUDFM_L @@ -489,10 +506,10 @@ alterUDFM_L f (UDFM m i) k = (fmap taggedFst mElt, UDFM udfm (i + 1)) where alterf :: Maybe (TaggedVal elt) -> (Maybe (TaggedVal elt)) - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i + alterf Nothing = inject i $ f Nothing + alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v) + inject _ Nothing = Nothing + inject tag (Just v) = Just $ TaggedVal v tag -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 ===================================== testsuite/tests/ghci/T16793/T16793.stdout ===================================== @@ -1,9 +1,9 @@ -instance Bounded Int -- Defined in ‘GHC.Internal.Enum’ +instance Eq Int -- Defined in ‘GHC.Internal.Classes’ +instance Ord Int -- Defined in ‘GHC.Internal.Classes’ instance Read Int -- Defined in ‘GHC.Internal.Read’ +instance Bounded Int -- Defined in ‘GHC.Internal.Enum’ instance Enum Int -- Defined in ‘GHC.Internal.Enum’ -instance Eq Int -- Defined in ‘GHC.Internal.Classes’ -instance Integral Int -- Defined in ‘GHC.Internal.Real’ instance Num Int -- Defined in ‘GHC.Internal.Num’ -instance Ord Int -- Defined in ‘GHC.Internal.Classes’ instance Real Int -- Defined in ‘GHC.Internal.Real’ instance Show Int -- Defined in ‘GHC.Internal.Show’ +instance Integral Int -- Defined in ‘GHC.Internal.Real’ ===================================== testsuite/tests/ghci/T18060/T18060.stdout ===================================== @@ -2,13 +2,13 @@ type (->) :: * -> * -> * type (->) = FUN Many -- Defined in ‘GHC.Internal.Types’ infixr -1 -> +instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Internal.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Internal.Base’ -instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ type (~) :: forall k. k -> k -> Constraint class (a ~ b) => (~) a b -- Defined in ‘GHC.Internal.Types’ ===================================== testsuite/tests/ghci/T27532/Makefile ===================================== @@ -0,0 +1,23 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T27532 +T27532: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < a.script 2>/dev/null | grep '^instance' > direct.txt + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < b.script 2>/dev/null | grep '^instance' > afterimport.txt + diff direct.txt afterimport.txt || true + +.PHONY: T27532j4 +T27532j4: + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_1.txt + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_2.txt + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_3.txt + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_4.txt + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_5.txt + printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_6.txt + diff j4_1.txt j4_2.txt || true + diff j4_1.txt j4_3.txt || true + diff j4_1.txt j4_4.txt || true + diff j4_1.txt j4_5.txt || true + diff j4_1.txt j4_6.txt || true ===================================== testsuite/tests/ghci/T27532/T27532.stdout ===================================== ===================================== testsuite/tests/ghci/T27532/T27532j4.stdout ===================================== ===================================== testsuite/tests/ghci/T27532/a.script ===================================== @@ -0,0 +1 @@ +:info () ===================================== testsuite/tests/ghci/T27532/all.T ===================================== @@ -0,0 +1,11 @@ +test('T27532', + [extra_files(['a.script', 'b.script']), + req_interp], + makefile_test, ['T27532']) + +test('T27532j4', + [pre_cmd('./genT27532Modules'), + extra_files(['genT27532Modules']), + req_interp, + req_ghc_smp], + makefile_test, ['T27532j4']) ===================================== testsuite/tests/ghci/T27532/b.script ===================================== @@ -0,0 +1,3 @@ +import Data.Ratio +_ <- return $! compare (1 % 2 :: Rational) (2 % 3) +:info () ===================================== testsuite/tests/ghci/T27532/genT27532Modules ===================================== @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +# Generate modules that each import and use a distinct instance-heavy module, +# so a parallel :load races many interface loads against each other. +gen() { f=$1; shift; printf '%s\n' "module ${f%.hs} where" "$@" > "$f"; } +gen M01.hs "import Data.Ratio" "v :: Rational" "v = 1 % 2" "s = show v" +gen M02.hs "import Data.Complex" "v :: Complex Double" "v = 1" "s = show v" +gen M03.hs "import Data.Fixed" "v :: Fixed E2" "v = 1" "s = show v" +gen M04.hs "import Foreign.C.Types" "v :: CInt" "v = 1" "s = show v" "b :: CInt" "b = maxBound" +gen M05.hs "import System.Posix.Types" "v :: CPid" "v = 1" "s = show v" +gen M06.hs "import Data.Version" "s = showVersion (makeVersion [1,2])" +gen M07.hs "import Control.Exception" "s = show DivideByZero" "t = show StackOverflow" +gen M08.hs "import Data.Dynamic" "s = show (toDyn ())" +gen M09.hs "import Type.Reflection" "s = show (typeRep :: TypeRep Bool)" +gen M10.hs "import Data.List.NonEmpty (NonEmpty(..))" "s = show (1 :| ([2,3] :: [Int]))" +gen M11.hs "import Data.Ord" "s = show (Down (3 :: Int))" "c = compare (Down 1) (Down (2 :: Int))" +gen M12.hs "import Data.Functor.Identity" "s = show (Identity (1 :: Int))" +gen M13.hs "import Data.Functor.Const" "s = show (Const (1 :: Int) :: Const Int Bool)" +gen M14.hs "import Data.Functor.Compose" "s = show (Compose (Just (Just (1 :: Int))))" +gen M15.hs "import Data.Functor.Product" "s = show (Pair (Just (1 :: Int)) (Just (2 :: Int)))" +gen M16.hs "import Data.Functor.Sum" "s = show (InL (Just (1 :: Int)) :: Sum Maybe Maybe Int)" +gen M17.hs "import Data.Monoid" "s = show (Sum (1 :: Int) <> Sum 2)" "a = show (All True)" +gen M18.hs "import Data.Semigroup" "s = show (Min (1 :: Int) <> Min 2)" +gen M19.hs "import Text.Printf" "s = printf \"%d\" (1 :: Int) :: String" +gen M20.hs "import Numeric.Natural" "s = show (5 :: Natural)" "v :: Natural" "v = 2 + 3" +gen M21.hs "import Foreign.Ptr" "s = show nullPtr" +gen M22.hs "import System.IO" "s = show stdout" "e = show stderr" +gen M23.hs "import Data.IORef" "v :: IO (IORef Int)" "v = newIORef 1" +gen M24.hs "import Data.Bits" "v = xor (1 :: Int) 2" "s = show v" +for f in M??.hs; do + n=${f#M}; n=${n%.hs} + m=$(printf 'M%02d' $((10#$n + 24))) + sed "s/module M$n/module $m/" "$f" > "$m.hs" +done ===================================== testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout ===================================== @@ -1,13 +1,13 @@ type Unit :: * data Unit = () -- Defined in ‘GHC.Internal.Tuple’ +instance Eq Unit -- Defined in ‘GHC.Internal.Classes’ instance Monoid Unit -- Defined in ‘GHC.Internal.Base’ +instance Ord Unit -- Defined in ‘GHC.Internal.Classes’ instance Semigroup Unit -- Defined in ‘GHC.Internal.Base’ -instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’ instance Read Unit -- Defined in ‘GHC.Internal.Read’ +instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’ instance Enum Unit -- Defined in ‘GHC.Internal.Enum’ -instance Eq Unit -- Defined in ‘GHC.Internal.Classes’ -instance Ord Unit -- Defined in ‘GHC.Internal.Classes’ instance Show Unit -- Defined in ‘GHC.Internal.Show’ type Unit# :: GHC.Internal.Types.ZeroBitType data Unit# = (##) @@ -15,23 +15,23 @@ data Unit# = (##) type Solo :: * -> * data Solo a = MkSolo a -- Defined in ‘GHC.Internal.Tuple’ -instance Traversable Solo - -- Defined in ‘GHC.Internal.Data.Traversable’ instance Applicative Solo -- Defined in ‘GHC.Internal.Base’ -instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’ +instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’ instance Functor Solo -- Defined in ‘GHC.Internal.Base’ instance Monad Solo -- Defined in ‘GHC.Internal.Base’ +instance Monoid a => Monoid (Solo a) + -- Defined in ‘GHC.Internal.Base’ +instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’ +instance Semigroup a => Semigroup (Solo a) + -- Defined in ‘GHC.Internal.Base’ instance Read a => Read (Solo a) -- Defined in ‘GHC.Internal.Read’ instance Bounded a => Bounded (Solo a) -- Defined in ‘GHC.Internal.Enum’ instance Enum a => Enum (Solo a) -- Defined in ‘GHC.Internal.Enum’ -instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’ instance Show a => Show (Solo a) -- Defined in ‘GHC.Internal.Show’ -instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’ -instance Monoid a => Monoid (Solo a) - -- Defined in ‘GHC.Internal.Base’ -instance Semigroup a => Semigroup (Solo a) - -- Defined in ‘GHC.Internal.Base’ +instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’ +instance Traversable Solo + -- Defined in ‘GHC.Internal.Data.Traversable’ () :: Unit (##) :: Unit# ( ) :: Unit @@ -39,29 +39,29 @@ instance Semigroup a => Semigroup (Solo a) type Tuple2 :: * -> * -> * data Tuple2 a b = (,) a b -- Defined in ‘GHC.Internal.Tuple’ -instance Traversable (Tuple2 a) - -- Defined in ‘GHC.Internal.Data.Traversable’ instance Monoid a => Applicative (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ -instance Foldable (Tuple2 a) - -- Defined in ‘GHC.Internal.Data.Foldable’ +instance (Eq a, Eq b) => Eq (Tuple2 a b) + -- Defined in ‘GHC.Internal.Classes’ instance Functor (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ instance Monoid a => Monad (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ instance (Monoid a, Monoid b) => Monoid (Tuple2 a b) -- Defined in ‘GHC.Internal.Base’ -instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b) - -- Defined in ‘GHC.Internal.Base’ -instance (Bounded a, Bounded b) => Bounded (Tuple2 a b) - -- Defined in ‘GHC.Internal.Enum’ instance (Ord a, Ord b) => Ord (Tuple2 a b) -- Defined in ‘GHC.Internal.Classes’ +instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b) + -- Defined in ‘GHC.Internal.Base’ instance (Read a, Read b) => Read (Tuple2 a b) -- Defined in ‘GHC.Internal.Read’ +instance (Bounded a, Bounded b) => Bounded (Tuple2 a b) + -- Defined in ‘GHC.Internal.Enum’ instance (Show a, Show b) => Show (Tuple2 a b) -- Defined in ‘GHC.Internal.Show’ -instance (Eq a, Eq b) => Eq (Tuple2 a b) - -- Defined in ‘GHC.Internal.Classes’ +instance Foldable (Tuple2 a) + -- Defined in ‘GHC.Internal.Data.Foldable’ +instance Traversable (Tuple2 a) + -- Defined in ‘GHC.Internal.Data.Traversable’ type Tuple2# :: * -> * -> TYPE ===================================== testsuite/tests/ghci/scripts/T4175.stdout ===================================== @@ -26,52 +26,52 @@ type Unit :: * data Unit = () -- Defined in ‘GHC.Internal.Tuple’ instance [safe] C () -- Defined at T4175.hs:22:10 +instance Eq () -- Defined in ‘GHC.Internal.Classes’ instance Monoid () -- Defined in ‘GHC.Internal.Base’ +instance Ord () -- Defined in ‘GHC.Internal.Classes’ instance Semigroup () -- Defined in ‘GHC.Internal.Base’ +instance Read () -- Defined in ‘GHC.Internal.Read’ instance Bounded () -- Defined in ‘GHC.Internal.Enum’ instance Enum () -- Defined in ‘GHC.Internal.Enum’ -instance Ord () -- Defined in ‘GHC.Internal.Classes’ -instance Read () -- Defined in ‘GHC.Internal.Read’ instance Show () -- Defined in ‘GHC.Internal.Show’ -instance Eq () -- Defined in ‘GHC.Internal.Classes’ data instance B () = MkB -- Defined at T4175.hs:14:15 type instance D Int () = String -- Defined at T4175.hs:20:10 type instance D () () = Bool -- Defined at T4175.hs:23:10 type Maybe :: * -> * data Maybe a = Nothing | Just a -- Defined in ‘GHC.Internal.Maybe’ -instance Traversable Maybe - -- Defined in ‘GHC.Internal.Data.Traversable’ -instance MonadFail Maybe - -- Defined in ‘GHC.Internal.Control.Monad.Fail’ instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’ -instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ +instance [safe] Eq a => Eq (Maybe a) + -- Defined in ‘GHC.Internal.Maybe’ instance Functor Maybe -- Defined in ‘GHC.Internal.Base’ instance Monad Maybe -- Defined in ‘GHC.Internal.Base’ instance Semigroup a => Monoid (Maybe a) -- Defined in ‘GHC.Internal.Base’ -instance Semigroup a => Semigroup (Maybe a) - -- Defined in ‘GHC.Internal.Base’ instance [safe] Ord a => Ord (Maybe a) -- Defined in ‘GHC.Internal.Maybe’ +instance Semigroup a => Semigroup (Maybe a) + -- Defined in ‘GHC.Internal.Base’ instance Read a => Read (Maybe a) -- Defined in ‘GHC.Internal.Read’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Internal.Show’ -instance [safe] Eq a => Eq (Maybe a) - -- Defined in ‘GHC.Internal.Maybe’ +instance MonadFail Maybe + -- Defined in ‘GHC.Internal.Control.Monad.Fail’ +instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ +instance Traversable Maybe + -- Defined in ‘GHC.Internal.Data.Traversable’ type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15 type Int :: * data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int# -- Defined in ‘GHC.Internal.Types’ instance [safe] C Int -- Defined at T4175.hs:19:10 +instance Eq Int -- Defined in ‘GHC.Internal.Classes’ +instance Ord Int -- Defined in ‘GHC.Internal.Classes’ +instance Read Int -- Defined in ‘GHC.Internal.Read’ instance Bounded Int -- Defined in ‘GHC.Internal.Enum’ instance Enum Int -- Defined in ‘GHC.Internal.Enum’ -instance Integral Int -- Defined in ‘GHC.Internal.Real’ instance Num Int -- Defined in ‘GHC.Internal.Num’ -instance Ord Int -- Defined in ‘GHC.Internal.Classes’ -instance Read Int -- Defined in ‘GHC.Internal.Read’ instance Real Int -- Defined in ‘GHC.Internal.Real’ instance Show Int -- Defined in ‘GHC.Internal.Show’ -instance Eq Int -- Defined in ‘GHC.Internal.Classes’ +instance Integral Int -- Defined in ‘GHC.Internal.Real’ type instance A Int Int = () -- Defined at T4175.hs:9:15 type instance D Int () = String -- Defined at T4175.hs:20:10 type Z :: * -> Constraint ===================================== testsuite/tests/ghci/scripts/T8469.stdout ===================================== @@ -1,12 +1,12 @@ type Int :: * data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int# -- Defined in ‘GHC.Internal.Types’ -instance Bounded Int -- Defined in ‘GHC.Internal.Enum’ +instance Eq Int -- Defined in ‘GHC.Internal.Classes’ +instance Ord Int -- Defined in ‘GHC.Internal.Classes’ instance Read Int -- Defined in ‘GHC.Internal.Read’ +instance Bounded Int -- Defined in ‘GHC.Internal.Enum’ instance Enum Int -- Defined in ‘GHC.Internal.Enum’ -instance Eq Int -- Defined in ‘GHC.Internal.Classes’ -instance Integral Int -- Defined in ‘GHC.Internal.Real’ instance Num Int -- Defined in ‘GHC.Internal.Num’ -instance Ord Int -- Defined in ‘GHC.Internal.Classes’ instance Real Int -- Defined in ‘GHC.Internal.Real’ instance Show Int -- Defined in ‘GHC.Internal.Show’ +instance Integral Int -- Defined in ‘GHC.Internal.Real’ ===================================== testsuite/tests/ghci/scripts/T8535.stdout ===================================== @@ -2,10 +2,10 @@ type (->) :: * -> * -> * type (->) = FUN Many -- Defined in ‘GHC.Internal.Types’ infixr -1 -> +instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Internal.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Internal.Base’ -instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/ghci/scripts/T9881.stdout ===================================== @@ -4,16 +4,16 @@ data Data.ByteString.Lazy.ByteString | Data.ByteString.Lazy.Internal.Chunk {-# UNPACK #-} !StrictByteString Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ +instance Eq Data.ByteString.Lazy.ByteString + -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Monoid Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ +instance Ord Data.ByteString.Lazy.ByteString + -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Semigroup Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Read Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ -instance Eq Data.ByteString.Lazy.ByteString - -- Defined in ‘Data.ByteString.Lazy.Internal’ -instance Ord Data.ByteString.Lazy.ByteString - -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Show Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ @@ -23,15 +23,15 @@ data Data.ByteString.ByteString GHC.Internal.Word.Word8) {-# UNPACK #-} !Int -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ +instance Eq Data.ByteString.ByteString + -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ instance Monoid Data.ByteString.ByteString -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ +instance Ord Data.ByteString.ByteString + -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ instance Semigroup Data.ByteString.ByteString -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ instance Read Data.ByteString.ByteString -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ -instance Eq Data.ByteString.ByteString - -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ -instance Ord Data.ByteString.ByteString - -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ instance Show Data.ByteString.ByteString -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’ ===================================== testsuite/tests/ghci/scripts/ghci020.stdout ===================================== @@ -2,10 +2,10 @@ type (->) :: * -> * -> * type (->) = FUN Many -- Defined in ‘GHC.Internal.Types’ infixr -1 -> +instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Internal.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Internal.Base’ -instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/ghci/scripts/ghci064.stdout ===================================== @@ -1,52 +1,52 @@ -instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ -instance Traversable Maybe - -- Defined in ‘GHC.Internal.Data.Traversable’ instance GHC.Internal.Base.Alternative Maybe -- Defined in ‘GHC.Internal.Base’ instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’ instance Functor Maybe -- Defined in ‘GHC.Internal.Base’ -instance MonadFail Maybe - -- Defined in ‘GHC.Internal.Control.Monad.Fail’ +instance Monad Maybe -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.MonadPlus Maybe -- Defined in ‘GHC.Internal.Base’ -instance Monad Maybe -- Defined in ‘GHC.Internal.Base’ +instance MonadFail Maybe + -- Defined in ‘GHC.Internal.Control.Monad.Fail’ +instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ +instance Traversable Maybe + -- Defined in ‘GHC.Internal.Data.Traversable’ +instance [safe] Eq w => Eq (Maybe w) + -- Defined in ‘GHC.Internal.Maybe’ instance Semigroup w => Monoid (Maybe w) -- Defined in ‘GHC.Internal.Base’ -instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’ -instance Semigroup w => Semigroup (Maybe w) - -- Defined in ‘GHC.Internal.Base’ instance [safe] Ord w => Ord (Maybe w) -- Defined in ‘GHC.Internal.Maybe’ +instance Semigroup w => Semigroup (Maybe w) + -- Defined in ‘GHC.Internal.Base’ +instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’ instance Show w => Show (Maybe w) -- Defined in ‘GHC.Internal.Show’ -instance [safe] Eq w => Eq (Maybe w) - -- Defined in ‘GHC.Internal.Maybe’ -instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’ -instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’ -instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’ instance Eq w => Eq [w] -- Defined in ‘GHC.Internal.Classes’ instance Monoid [w] -- Defined in ‘GHC.Internal.Base’ +instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’ instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’ +instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’ +instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’ instance [safe] MyShow w => MyShow [w] -- Defined at ghci064.hs:8:10 instance Monoid [T] -- Defined in ‘GHC.Internal.Base’ instance Semigroup [T] -- Defined in ‘GHC.Internal.Base’ instance [safe] MyShow [T] -- Defined at ghci064.hs:16:10 instance [safe] MyShow [T] -- Defined at ghci064.hs:8:10 -instance GHC.Internal.Foreign.Storable.Storable Bool - -- Defined in ‘GHC.Internal.Foreign.Storable’ -instance GHC.Internal.Bits.Bits Bool - -- Defined in ‘GHC.Internal.Bits’ +instance Eq Bool -- Defined in ‘GHC.Internal.Classes’ +instance Ord Bool -- Defined in ‘GHC.Internal.Classes’ +instance Read Bool -- Defined in ‘GHC.Internal.Read’ instance Bounded Bool -- Defined in ‘GHC.Internal.Enum’ instance Enum Bool -- Defined in ‘GHC.Internal.Enum’ +instance Show Bool -- Defined in ‘GHC.Internal.Show’ +instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’ +instance GHC.Internal.Bits.Bits Bool + -- Defined in ‘GHC.Internal.Bits’ instance GHC.Internal.Bits.FiniteBits Bool -- Defined in ‘GHC.Internal.Bits’ -instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’ -instance Ord Bool -- Defined in ‘GHC.Internal.Classes’ -instance Read Bool -- Defined in ‘GHC.Internal.Read’ -instance Show Bool -- Defined in ‘GHC.Internal.Show’ -instance Eq Bool -- Defined in ‘GHC.Internal.Classes’ -instance Traversable ((,) Int) - -- Defined in ‘GHC.Internal.Data.Traversable’ +instance GHC.Internal.Foreign.Storable.Storable Bool + -- Defined in ‘GHC.Internal.Foreign.Storable’ +instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’ instance Foldable ((,) Int) -- Defined in ‘GHC.Internal.Data.Foldable’ -instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’ +instance Traversable ((,) Int) + -- Defined in ‘GHC.Internal.Data.Traversable’ ===================================== testsuite/tests/ghci/should_run/T10145.stdout ===================================== @@ -2,10 +2,10 @@ type (->) :: * -> * -> * type (->) = FUN Many -- Defined in ‘GHC.Internal.Types’ infixr -1 -> +instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Internal.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Internal.Base’ -instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/ghci/should_run/T18594.stdout ===================================== @@ -2,13 +2,13 @@ type (->) :: * -> * -> * type (->) = FUN Many -- Defined in ‘GHC.Internal.Types’ infixr -1 -> +instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ +instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Internal.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Internal.Base’ -instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’ -instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’ type Constraint :: * type Constraint = CONSTRAINT LiftedRep -- Defined in ‘GHC.Internal.Types’ ===================================== testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr ===================================== @@ -21,7 +21,7 @@ TYPE SIGNATURES (>>) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b (>>=) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b - (^) :: forall {b} {a}. (Integral b, Num a) => a -> b -> a + (^) :: forall {a} {b}. (Num a, Integral b) => a -> b -> a (^^) :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a abs :: forall {a}. Num a => a -> a acos :: forall {a}. Floating a => a -> a @@ -236,4 +236,4 @@ TYPE SIGNATURES (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] (||) :: Bool -> Bool -> Bool Dependent modules: [] -Dependent packages: [(normal, base-4.21.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ===================================== testsuite/tests/roles/should_compile/Roles14.stderr ===================================== @@ -4,7 +4,7 @@ TYPE CONSTRUCTORS class C2{1} :: * -> Constraint roles representational Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== Roles12.$tcC2 [InlPrag=[~]] @@ -15,14 +15,14 @@ Roles12.$tc'C:C2 [InlPrag=[~]] = GHC.Internal.Types.TyCon 7087988437584478859#Word64 11477953550142401435#Word64 Roles12.$trModule (GHC.Internal.Types.TrNameS "'C:C2"#) 1# $krep -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep []) $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep []) Roles12.$trModule [InlPrag=[~]] = GHC.Internal.Types.Module (GHC.Internal.Types.TrNameS "main"#) ===================================== testsuite/tests/roles/should_compile/Roles3.stderr ===================================== @@ -16,7 +16,7 @@ TYPE CONSTRUCTORS roles nominal type synonym Syn2{1} :: * -> * Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== Roles3.$tcC4 [InlPrag=[~]] @@ -43,15 +43,6 @@ Roles3.$tc'C:C1 [InlPrag=[~]] = GHC.Internal.Types.TyCon 4508088879886988796#Word64 13962145553903222779#Word64 Roles3.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp - GHC.Internal.Types.$tc~ - ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep []))) -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp - Roles3.$tcC2 ((:) $krep ((:) $krep [])) -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep []) $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep @@ -64,6 +55,15 @@ $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp + GHC.Internal.Types.$tc~ + ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep []))) +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp + Roles3.$tcC2 ((:) $krep ((:) $krep [])) +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep []) Roles3.$trModule [InlPrag=[~]] = GHC.Internal.Types.Module (GHC.Internal.Types.TrNameS "main"#) ===================================== testsuite/tests/roles/should_compile/Roles4.stderr ===================================== @@ -6,7 +6,7 @@ TYPE CONSTRUCTORS class C3{1} :: * -> Constraint type synonym Syn1{1} :: * -> * Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== Roles4.$tcC3 [InlPrag=[~]] @@ -25,10 +25,6 @@ Roles4.$tc'C:C1 [InlPrag=[~]] = GHC.Internal.Types.TyCon 3870707671502302648#Word64 10631907186261837450#Word64 Roles4.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep []) -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep []) $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep @@ -40,6 +36,10 @@ $krep [InlPrag=[~]] $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepTyConApp GHC.Internal.Types.$tcList ((:) $krep []) +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep []) +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep []) Roles4.$trModule [InlPrag=[~]] = GHC.Internal.Types.Module (GHC.Internal.Types.TrNameS "main"#) ===================================== testsuite/tests/roles/should_compile/T8958.stderr ===================================== @@ -18,7 +18,7 @@ CLASS INSTANCES instance [incoherent] Representational a -- Defined at T8958.hs:11:10 Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== T8958.$tcMap [InlPrag=[~]] @@ -50,10 +50,10 @@ T8958.$tc'C:Nominal [InlPrag=[~]] T8958.$trModule (GHC.Internal.Types.TrNameS "'C:Nominal"#) 1# $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1 -$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint +$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepTyConApp GHC.Internal.Tuple.$tcTuple2 ===================================== testsuite/tests/typecheck/should_compile/T18406b.stderr ===================================== @@ -4,7 +4,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS class C{2} :: * -> * -> Constraint Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== Bug.$tcC [InlPrag=[~]] @@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]] = GHC.Internal.Types.TyCon 302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule (GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp - Bug.$tcC - ((:) @GHC.Internal.Types.KindRep - $krep - ((:) @GHC.Internal.Types.KindRep - $krep [] @GHC.Internal.Types.KindRep)) $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep @@ -31,6 +24,13 @@ $krep [InlPrag=[~]] $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp + Bug.$tcC + ((:) @GHC.Internal.Types.KindRep + $krep + ((:) @GHC.Internal.Types.KindRep + $krep [] @GHC.Internal.Types.KindRep)) Bug.$trModule [InlPrag=[~]] = GHC.Internal.Types.Module (GHC.Internal.Types.TrNameS "main"#) ===================================== testsuite/tests/typecheck/should_compile/T18529.stderr ===================================== @@ -4,7 +4,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS class C{2} :: * -> * -> Constraint Dependent modules: [] -Dependent packages: [(normal, base-4.22.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Typechecker ==================== Bug.$tcC [InlPrag=[~]] @@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]] = GHC.Internal.Types.TyCon 302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule (GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep -$krep [InlPrag=[~]] - = GHC.Internal.Types.KindRepTyConApp - Bug.$tcC - ((:) @GHC.Internal.Types.KindRep - $krep - ((:) @GHC.Internal.Types.KindRep - $krep [] @GHC.Internal.Types.KindRep)) $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1 $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep @@ -35,6 +28,13 @@ $krep [InlPrag=[~]] $krep [InlPrag=[~]] = GHC.Internal.Types.KindRepTyConApp GHC.Internal.Tuple.$tcUnit [] @GHC.Internal.Types.KindRep +$krep [InlPrag=[~]] + = GHC.Internal.Types.KindRepTyConApp + Bug.$tcC + ((:) @GHC.Internal.Types.KindRep + $krep + ((:) @GHC.Internal.Types.KindRep + $krep [] @GHC.Internal.Types.KindRep)) Bug.$trModule [InlPrag=[~]] = GHC.Internal.Types.Module (GHC.Internal.Types.TrNameS "main"#) ===================================== testsuite/tests/typecheck/should_fail/T5300.stderr ===================================== @@ -1,4 +1,3 @@ - T5300.hs:12:7: error: [GHC-39999] • Could not deduce ‘C1 a b c0’ from the context: (Monad m, C1 a b c) @@ -14,16 +13,17 @@ T5300.hs:12:7: error: [GHC-39999] f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a T5300.hs:15:7: error: [GHC-39999] - • Could not deduce ‘C1 a1 b1 c10’ + • Could not deduce ‘C2 a2 b2 c20’ from the context: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) bound by the type signature for: f2 :: forall (m :: * -> *) a1 b1 c1 a2 b2 c2. (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2 at T5300.hs:15:7-69 - The type variable ‘c10’ is ambiguous + The type variable ‘c20’ is ambiguous • In the ambiguity check for ‘f2’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes In the type signature: f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa074c95c8a48ae5d29a299be535445… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa074c95c8a48ae5d29a299be535445… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] ci: add missing workaround for docker permissions in lint jobs
by Marge Bot (＠marge-bot) 24 Jul '26

24 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7b116a0b by Cheng Shao at 2026-07-24T18:06:24-04:00 ci: add missing workaround for docker permissions in lint jobs Some lint jobs use ci-images with default user `ghc`, and the gitlab ci docker executor requires the `sudo chown` workaround to fix workspace directory permission issue. This patch adds the missing workarounds for the lint jobs. Fixes #27554. Co-authored-by: Codex <codex(a)openai.com> - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -266,7 +266,8 @@ lint-changelog: GIT_SUBMODULE_STRATEGY: none before_script: - export PATH="/opt/toolchain/bin:$PATH" - - git config --global --add safe.directory "$CI_PROJECT_DIR" + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - .gitlab/ci.sh lint_changelog dependencies: [] @@ -283,6 +284,9 @@ lint-linters: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - mypy testsuite/tests/linters/regex-linters/*.py dependencies: [] @@ -294,6 +298,9 @@ lint-testsuite: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - make -Ctestsuite list_broken TEST_HC=$GHC dependencies: [] @@ -305,6 +312,9 @@ typecheck-testsuite: variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - mypy testsuite/driver/runtests.py dependencies: [] @@ -335,6 +345,9 @@ lint-author: extends: .lint variables: GIT_SUBMODULE_STRATEGY: none + before_script: + # workaround for docker permissions + - sudo chown ghc:ghc -R . script: - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b116a0beeee04c822995f10dd8098d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b116a0beeee04c822995f10dd8098d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Fix flaky test T3994 on FreeBSD
by Marge Bot (＠marge-bot) 24 Jul '26

24 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 306120d2 by Duncan Coutts at 2026-07-24T18:05:43-04:00 Fix flaky test T3994 on FreeBSD On current FreeBSD versions, calling getpgid on a zombie process fails. In T3994, if we're really unlucky with delays and scheduling then we can end up in exactly that situation. Just catch that specific exception and ignore it. It's rare, and not our fault. - - - - - 1 changed file: - testsuite/tests/process/T3994.hs Changes: ===================================== testsuite/tests/process/T3994.hs ===================================== @@ -1,7 +1,10 @@ module Main where import Control.Concurrent +import Control.Exception +import Control.Monad import System.IO +import System.IO.Error import System.Process main :: IO () @@ -9,14 +12,24 @@ main = do (_,Just hout,_,p) <- createProcess (proc "./T3994app" ["start", "10000 { std_out = CreatePipe, create_group = True } start <- hGetLine hout putStrLn start - interruptProcessGroupOf p - t <- myThreadId - -- timeout - forkIO $ do - threadDelay 5000000 - putStrLn "Interrupting a Running Process Failed" - hFlush stdout - killThread t - waitForProcess p + + -- On FreeBSD if we're _really_ unlucky with scheduling, then the + -- call to interruptProcessGroupOf can fail due to the process + -- having already terminated (despite it running for at least 10ms!) + -- If so, we just skip doing anything rather than fail the test, + -- since this isn't our fault and is rare and scheduling dependent. + -- See #27512 and https://reviews.freebsd.org/D58393 + handleJust (guard . isDoesNotExistError) (\_ -> return ()) $ do + interruptProcessGroupOf p + t <- myThreadId + -- timeout + forkIO $ do + threadDelay 5000000 + putStrLn "Interrupting a Running Process Failed" + hFlush stdout + killThread t + waitForProcess p + return () + putStrLn "end" return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/306120d22191358f227175c2cc3c2e4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/306120d22191358f227175c2cc3c2e4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0