- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: rts: fix -Wcompare-distinct-pointer-types errors
by Marge Bot (＠marge-bot) 22 Mar '26

22 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: de54e264 by Cheng Shao at 2026-03-21T17:52:08+01:00 rts: fix -Wcompare-distinct-pointer-types errors This commit fixes `-Wcompare-distinct-pointer-types` errors in the RTS which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. - - - - - b9bd73de by Cheng Shao at 2026-03-21T17:52:08+01:00 ghc-internal: fix unused imports This commit fixes unused imports in `ghc-internal` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - da946a16 by Cheng Shao at 2026-03-21T17:03:51+00:00 ghci: fix unused imports This commit fixes unused imports in `ghci` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - 955b1cf8 by Cheng Shao at 2026-03-21T17:03:51+00:00 compiler: fix unused imports in GHC.Tc.Types.Origin This commit fixes unused imports in `GHC.Tc.Types.Origin` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #27059. - - - - - 3b1aeb50 by Cheng Shao at 2026-03-21T17:03:51+00:00 hadrian: fix missing +werror in validate flavour This patch fixes missing `+werror` in validate flavour, which was an oversight in bb3a2ba1eefadf0b2ef4f39b31337a23eec67f29. Fixes #27066. - - - - - 2d074ab8 by Cheng Shao at 2026-03-21T21:10:45-04:00 ci: bump CACHE_REV and add the missing reminder This patch bumps `CACHE_REV` to address recent `[Cabal-7159]` CI errors due to stale cabal cache on some runners, and also adds a reminder to remind future maintainers. Fixes #27075. - - - - - 21 changed files: - .gitlab-ci.yml - compiler/GHC/Tc/Types/Origin.hs - hadrian/cabal.project - hadrian/src/Settings/Flavours/Validate.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Server.hs - rts/Interpreter.c Changes: ===================================== .gitlab-ci.yml ===================================== @@ -15,7 +15,7 @@ variables: # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. - CACHE_REV: 11 + CACHE_REV: 12 # Disable shallow clones; they break our linting rules GIT_DEPTH: 0 ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -83,7 +83,6 @@ import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import qualified Data.Semigroup as Semi -import GHC.Generics {- ********************************************************************* * * ===================================== hadrian/cabal.project ===================================== @@ -4,6 +4,8 @@ packages: ./ -- This essentially freezes the build plan for hadrian -- It would be wise to keep this up to date with the state set in .gitlab/ci.sh. +-- Also remember to bump CACHE_REV in .gitlab-ci.yml, otherwise stale +-- cabal cache on some runners may result in [Cabal-7159] errors. index-state: 2026-03-10T17:36:36Z -- N.B. Compile with -O0 since this is not a performance-critical executable ===================================== hadrian/src/Settings/Flavours/Validate.hs ===================================== @@ -8,7 +8,7 @@ import {-# SOURCE #-} Settings.Default -- Please update doc/flavours.md when changing this file. validateFlavour :: Flavour -validateFlavour = enableLinting $ quickValidateFlavour +validateFlavour = enableLinting $ werror $ quickValidateFlavour { name = "validate" , extraArgs = validateArgs <> defaultHaddockExtraArgs , ghcDebugAssertions = (<= Stage1) ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Internal.Conc.IO #endif ) where -import GHC.Internal.Base (otherwise, pure, return, ($)) +import GHC.Internal.Base (otherwise, return, ($)) import GHC.Internal.Conc.Sync as Sync import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.STM as STM @@ -82,6 +82,10 @@ import qualified GHC.Internal.Wasm.Prim.Conc as Wasm import qualified GHC.Internal.Wasm.Prim.Flag as Wasm #endif +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + ensureIOManagerIsRunning :: IO () #if defined(javascript_HOST_ARCH) ensureIOManagerIsRunning = pure () ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Control.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Internal.Event.Control #include <ghcplatform.h> #include "EventConfig.h" -import GHC.Internal.Base (fmap, otherwise, pure, return, when, ($), (.)) +import GHC.Internal.Base (fmap, otherwise, return, when, ($), (.)) import GHC.Internal.Classes (Eq(..), (&&)) import GHC.Internal.IORef import GHC.Internal.Conc.Signal (Signal) @@ -56,6 +56,10 @@ import GHC.Internal.Foreign.C.Types (CULLong(..)) import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF) #endif +#if defined(wasm32_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc ===================================== @@ -33,7 +33,7 @@ import GHC.Internal.Data.Bits (Bits(..), FiniteBits(..)) import GHC.Internal.Err (errorWithoutStackTrace, undefined) import GHC.Internal.Int import GHC.Internal.Data.Maybe (Maybe(..), catMaybes) -import GHC.Internal.Types (Bool(..), Int, IO) +import GHC.Internal.Types (Bool(..), IO) import GHC.Internal.Word (Word16, Word32) import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, eNOTSUP, getErrno, throwErrno) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -185,12 +185,12 @@ import GHC.Internal.Prim ( decodeFloat_Int#, divideFloat#, double2Float#, eqWord#, expDouble#, expFloat#, expm1Double#, expm1Float#, fabsDouble#, fabsFloat#, float2Double#, geFloat#, gtFloat#, gtWord#, int2Float#, int2Double#, - int2Word#, int64ToInt#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, + int2Word#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, logFloat#, ltFloat#, ltWord#, minusFloat#, minusWord#, negateDouble#, negateFloat#, negateInt#, plusFloat#, powerFloat#, sinDouble#, sinFloat#, sinhDouble#, sinhFloat#, sqrtDouble#, sqrtFloat#, tanDouble#, tanFloat#, tanhDouble#, tanhFloat#, timesFloat#, uncheckedIShiftRA#, uncheckedShiftL#, - word2Float#, word2Double#, word2Int#, word64ToWord#, + word2Float#, word2Double#, word2Int#, (+#), (+##), (-#), (-##), (*##), (**##), (/##), (<#), (<##), (<=#), (<=##), (>#), (>##), (>=#), (>=##), ) @@ -206,6 +206,13 @@ import GHC.Internal.Float.RealFracMethods import GHC.Internal.Float.ConversionUtils import GHC.Internal.Bignum.BigNat +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Prim ( + int64ToInt#, + word64ToWord#, + ) +#endif + infixr 8 ** -- $setup ===================================== libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Num () -- instance Num Integer -- (We could remove uses with a little effort) import GHC.Internal.Prim ( - Int#, eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, + eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, int2Double#, int2Word#, ltFloat#, minusFloat#, negateFloat#, negateDouble#, negateInt#, uncheckedIShiftL#, uncheckedIShiftRA#, uncheckedIShiftRL#, (+#), (-#), (<#), (>#), (-##), (==##), (<##), @@ -86,6 +86,10 @@ import GHC.Internal.Prim ( #else +import GHC.Internal.Prim ( + Int#, + ) + #define TO64 integerToInt# #define FROM64 IS #define MINUS64 ( -# ) @@ -355,4 +359,3 @@ foreign import ccall unsafe "rintDouble" foreign import ccall unsafe "rintFloat" c_rintFloat :: Float -> Float - ===================================== libraries/ghc-internal/src/GHC/Internal/IO/FD.hs ===================================== @@ -30,7 +30,7 @@ module GHC.Internal.IO.FD ( ) where import GHC.Internal.Base ( - String, fmap, id, otherwise, pure, return, when, ($), (.), (++), (>>=), + String, fmap, otherwise, pure, return, when, ($), (.), (++), (>>=), ) import GHC.Internal.Bits import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) @@ -58,6 +58,10 @@ import GHC.Internal.Err (error) import GHC.Internal.Windows import GHC.Internal.IO.SubSystem ((<!>)) import GHC.Internal.Foreign.Storable +#else +import GHC.Internal.Base ( + id, + ) #endif import GHC.Internal.Foreign.C.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Int.hs ===================================== @@ -51,7 +51,7 @@ import GHC.Internal.Classes ( Eq(..), Ord(..), eqInt, neInt, gtInt, geInt, ltInt, leInt, divInt8#, divInt16#, divInt32#, - divModInt8#, divModInt16#, divModInt32#, divModInt#, + divModInt8#, divModInt16#, divModInt32#, modInt8#, modInt16#, modInt32#, (&&), (||), ) @@ -63,6 +63,12 @@ import GHC.Internal.Arr import GHC.Internal.Show import GHC.Internal.Types (Bool(..), Float, Double, Int(..), isTrue#) +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Classes ( + divModInt#, + ) +#endif + ------------------------------------------------------------------------ -- type Int8 ------------------------------------------------------------------------ ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Ptr import GHC.Internal.Types (Bool(..), Double, Int) import GHC.Internal.Word import GHC.Internal.Base ( - String, otherwise, pure, return, (.), (++), (<*>), (=<<), + String, otherwise, return, (.), (++), (<*>), (=<<), ) import GHC.Internal.Enum import GHC.Internal.Generics (Generic) @@ -74,6 +74,10 @@ import GHC.Internal.IO import GHC.Internal.Real import GHC.Internal.Show +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + -- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- -- @since base-4.8.2.0 ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc ===================================== @@ -8,16 +8,20 @@ module GHC.Internal.RTS.Flags.Test ) where -import GHC.Internal.Base (pure) import GHC.Internal.Ptr -import GHC.Internal.Foreign.C.Types -import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import GHC.Internal.Data.Functor ((<$>)) import GHC.Internal.Types (Bool(..), Int, IO) import GHC.Internal.Word (Word32) import GHC.Internal.Real (fromIntegral) +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#else +import GHC.Internal.Foreign.C.Types +import GHC.Internal.Foreign.Marshal.Utils +#endif + #include "Rts.h" #include "rts/Flags.h" ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment.hs ===================================== @@ -49,9 +49,13 @@ import GHC.Internal.Base (fmap) import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Control.Exception.Base (bracket) import GHC.Internal.Err (undefined) +#else +import GHC.Internal.Base ( + map, (++), + ) #endif import GHC.Internal.Base ( - String, liftM, map, mapM, otherwise, return, ($), (.), (++), (>>=), + String, liftM, mapM, otherwise, return, ($), (.), (>>=), ) import GHC.Internal.List (null, elem, takeWhile, break) import GHC.Internal.Maybe (Maybe(..)) ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc ===================================== @@ -43,7 +43,7 @@ import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Data.Functor import GHC.Internal.Data.List (elem, null, takeWhile) import GHC.Internal.Foreign.C.String -import GHC.Internal.Base (String, otherwise, return, ($)) +import GHC.Internal.Base (String, otherwise, ($)) #if defined(mingw32_HOST_OS) import GHC.Internal.Base ((.)) import GHC.Internal.Foreign.Ptr @@ -51,6 +51,7 @@ import GHC.Internal.Windows import GHC.Internal.Control.Monad import GHC.Internal.Data.List (lookup) #else +import GHC.Internal.Base (return) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Real (fromIntegral) ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -249,6 +249,7 @@ import GHC.Internal.Base (String, failIO, otherwise, return, ($), (.), (>>=)) import GHC.Internal.List #if !defined(mingw32_HOST_OS) import GHC.Internal.IORef +import GHC.Internal.Types (Int) #endif import GHC.Internal.Num import GHC.Internal.IO hiding ( bracket, onException ) @@ -262,7 +263,7 @@ import GHC.Internal.IO.Encoding import GHC.Internal.Text.Read import GHC.Internal.IO.StdHandles import GHC.Internal.Show -import GHC.Internal.Types (Bool(..), Char, Int) +import GHC.Internal.Types (Bool(..), Char) ----------------------------------------------------------------------------- -- Standard IO ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -46,19 +46,20 @@ import GHC.Internal.Data.Maybe #if !defined(HTYPE_TCFLAG_T) import GHC.Internal.System.IO.Error +#if !defined(mingw32_HOST_OS) +import GHC.Internal.Err (errorWithoutStackTrace) +#endif #endif import GHC.Internal.Base ( String, otherwise, pure, return, when, ($), (++), (>>=), ) import GHC.Internal.Bits -import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) -import GHC.Internal.CString (cstringLength#) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Classes (Eq(..), not, (&&), (||)) import GHC.Internal.Num import GHC.Internal.Prim (yield#) import GHC.Internal.Real -import GHC.Internal.Types (Bool(..), Int(..)) +import GHC.Internal.Types (Bool(..)) import GHC.Internal.Word import GHC.Internal.IO import GHC.Internal.IO.IOMode @@ -71,10 +72,13 @@ import GHC.Internal.Int (Int64) #endif #if !defined(mingw32_HOST_OS) +import GHC.Internal.CString (cstringLength#) +import GHC.Internal.Classes (Ord(..)) import {-# SOURCE #-} GHC.Internal.IO.Encoding (getFileSystemEncoding) import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import qualified GHC.Internal.Foreign.C.String.Encoding as GHC +import GHC.Internal.Types (Int(..)) #else import GHC.Internal.Int import GHC.Internal.Data.OldList (elem) ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -39,12 +39,12 @@ module GHC.Internal.TopHandler ( import GHC.Internal.Control.Exception import GHC.Internal.Data.Maybe -import GHC.Internal.Classes (Eq(..), Ord(..), (&&)) +import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String import GHC.Internal.Base ( - String, const, failIO, otherwise, pure, return, ($), (++), (>>), + String, failIO, return, ($), (++), (>>), ) import GHC.Internal.Conc.Sync hiding (throwTo) import GHC.Internal.Prim (Weak#, seq) @@ -67,6 +67,17 @@ import GHC.Internal.Conc.Signal import GHC.Internal.Data.Dynamic (toDyn) #endif +#if !defined(HAVE_SIGNAL_H) +import GHC.Internal.Base (pure) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH) +import GHC.Internal.Base ( + const, otherwise, + ) +import GHC.Internal.Classes (Ord(..), (&&)) +#endif + -- Note [rts_setMainThread must be called unsafely] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- rts_setMainThread must be called as unsafe, because it ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -71,7 +71,6 @@ import qualified GHC.Boot.TH.Monad as TH import System.Exit import System.IO import System.IO.Error -import Data.Word (Word8) -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -26,7 +26,6 @@ import GHC.Wasm.Prim #else import GHCi.Utils #endif -import Data.Word (Word8) import Control.DeepSeq import Control.Exception ===================================== rts/Interpreter.c ===================================== @@ -718,7 +718,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + else if(Sp_plusW(offset_words) < (void*)(cur_stack->stack + cur_stack->stack_size)) { // Still inside the stack chunk return Sp_plusW(offset_words); } else { @@ -2469,7 +2469,7 @@ run_BCO: threadStackUnderflow(cap, cap->r.rCurrentTSO); LOAD_STACK_POINTERS; by -= sp_to_uf; - } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + } else if (Sp_plusW(by) < (void*)(stk->stack + stk->stack_size)) { // we're within the first stack chunk, this chunk has // no underflow frame break; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55fb9b8740bbea98eb5110c0cae61d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55fb9b8740bbea98eb5110c0cae61d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] More from Simon
by Simon Peyton Jones (＠simonpj) 22 Mar '26

22 Mar '26

Simon Peyton Jones pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: c412f218 by Simon Peyton Jones at 2026-03-22T00:06:33+00:00 More from Simon - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Types/LclEnv.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -662,9 +662,13 @@ type instance XXExpr GhcTc = XXExprGhcTc -- See Note [Rebindable syntax and XXExprGhcRn] -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` -data HsExpansion p = HSE { hs_ctxt :: HsCtxt -- The original source thing context to be used for error messages - , expanded_expr :: LHsExpr p } -- The compiler generated, expanded expression - -- This is located because of do statements (TODO ANI : Add Note) +data HsExpansion p + = HSE { hse_ctxt :: HsCtxt -- The original source thing context, + -- to be used for error messages + , hse_exp :: LHsExpr p -- The compiler generated expansion + -- This is located because of do statements + -- (TODO ANI : Add Note) + } data XXExprGhcRn = ExpandedThingRn (HsExpansion GhcRn) -- ^ Renamed/Pre Typecheck expanded expression ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -46,7 +46,10 @@ import Data.List ((\\)) -- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary -- and Note [Handling overloaded and rebindable constructs] for high level commentary expandDoStmts :: HsDoFlavour -> XRec GhcRn [ExprLStmt GhcRn] -> TcM (HsExpansion GhcRn) -expandDoStmts doFlav lstmts@(L _ stmts) = HSE (ExprCtxt (HsDo noExtField doFlav lstmts)) <$> expand_do_stmts doFlav stmts +expandDoStmts doFlav lstmts@(L _ stmts) + = do { exp <- expand_do_stmts doFlav stmts + ; return $ HSE { hse_ctxt = ExprCtxt (HsDo noExtField doFlav lstmts) + , hse_exp = exp } } -- | The main work horse for expanding do block statements into applications of binds and thens -- See Note [Expanding HsDo with XXExprGhcRn] ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -798,8 +798,8 @@ Example: Typechecking the do expression. The typechecker looks (somewhat) like t The `expandDoStmts` replaces the HsDo { x <- e1; return x } with something like - HSE { hs_ctxt = e - , expanded_expr = e1 >>= \ x -> x } + HSE { hse_ctxt = ExprCtxt e + , hse_exp = e1 >>= \ x -> x } and we then typecheck the expression `e1 >>= \ x -> x` See also Note [Handling overloaded and rebindable constructs] @@ -812,8 +812,8 @@ The rest of this Note explains how that is done. * The expansion process typically takes a user written thing L lspan ue and returns - L lspan (XExpr (ExpandedThingRn (HSE { hs_ctxt = ue - , expanded_expr = ee } )) + L lspan (XExpr (ExpandedThingRn (HSE { hse_ctxt = ue + , hse_exp = ee } )) where `ee` is the expansion of the user written thing `ue` * The type checker context has 3 key fields that describe the context: @@ -830,36 +830,32 @@ The rest of this Note explains how that is done. The `tcl_in_gen_code` is a boolean that keeps track of whether the current expression being typechecked is compiler generated or user generated. - INVARIANT: `tcl_in_gen_code` is modified only in `setSrcSpan`. + INVARIANT: `tcl_loc` and `tcl_in_gen_code` are modified only in `setSrcSpan`. * Now, when tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) gets a located expression, it does 3 things: (a) Calls `setSrcSpanA` to set the ambient source-code location - (b) Calls `addExprCtxt` to add a suitable `HsCtxt` on top of the `tcl_err_ctxt`. + (b) Calls `addExprCtxt` to push a suitable `HsCtxt` on top of the `tcl_err_ctxt`. (c) Calls `tcExpr` to typecheck the expression. * In these calls, if the `span` is generated (see `isGeneratedSrcSpan`), then - - `setSrcSpanA` sets `tcl_in_gen_code` to `True` - - `addErrCtxt` is a no-op if `tcl_in_gen_code` is True - This is how we avoid populating the TcLclCtxt with generated code. - -* The type checker error-stack element `GHC.Tc.Types.ErrCtxt.HsCtxt` - just stores an error message - - type ErrCtxtStack = [HsCtxt] - - When called on an `XExpr`, `addLExprCtxt`, adds the user written thing - `ue`, and the error message provided by the caller on the `ErrCtxtStack` See - Note [ErrCtxtStack Manipulation] for more details. - + - `setSrcSpanA` sets `tcl_in_gen_code` to `True`, and leaves `tcl_loc` unchanged + - `addExprCtxt` is a no-op if `tcl_in_gen_code` is True + The result is that `tcl_loc` has the span from the innermost /user/ tree node; + and the ErrCtxtStack in `tcl_err_ctxt` only has contexts arisign from user code. + +* Note that inside an expansion we have sub-expressions from the original program. + As soon as we enter one of those, identified by a /user/ span, `setSrcSpanA` will + sets the `tcl_loc` to reflect that span, and switch off `tcl_in_gen_code`. Nice! -} tcHsExpansion :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcHsExpansion (HSE o e) res_ty - = do e' <- tcMonoLExpr e res_ty - return $ XExpr (ExpandedThingTc (HSE o e')) +tcHsExpansion (HSE { hse_ctxt = o, hse_exp = e }) res_ty + = do { e' <- tcMonoLExpr e res_ty + ; return $ XExpr $ ExpandedThingTc $ + HSE { hse_ctxt = o, hse_exp = e' } } {- ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -168,14 +168,12 @@ getLclEnvErrCtxt = tcl_err_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) --- See Note [ErrCtxtStack Manipulation] addLclEnvErrCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv addLclEnvErrCtxt ec = setLclEnvHsCtxt ec setLclEnvHsCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv setLclEnvHsCtxt ec = modifyLclCtxt (setLclCtxtHsCtxt ec) --- See Note [ErrCtxtStack Manipulation] setLclCtxtHsCtxt :: HsCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtHsCtxt ec lclCtxt -- Never stack 2 statement error contexts on top of each other View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c412f21899015334797f9471350aaeb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c412f21899015334797f9471350aaeb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] Tidying up from Simon
by Simon Peyton Jones (＠simonpj) 22 Mar '26

22 Mar '26

Simon Peyton Jones pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 4b99e8e7 by Simon Peyton Jones at 2026-03-21T21:54:07+00:00 Tidying up from Simon - - - - - 14 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -1447,7 +1447,7 @@ mkErrorReport :: CtLocEnv -- ^ Suggested fixes -> TcM (MsgEnvelope TcRnMessage) mkErrorReport tcl_env msg mb_ctxt supp hints - = do { mb_context <- traverse (\ ctxt -> mkErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt + = do { mb_context <- traverse (\ ctxt -> tidyErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt ; unit_state <- hsc_units <$> getTopEnv ; hfdc <- getHoleFitDispConfig ; let ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7650,7 +7650,7 @@ pprTypeSyntaxName ContextArrowSyntax = "context arrow (=>)" pprTypeSyntaxName FunctionArrowSyntax = "function type arrow (->)" -------------------------------------------------------------------------------- --- ErrCtxt +-- HsCtxt pprTyConInstFlavour :: TyConInstFlavour -> SDoc pprTyConInstFlavour ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -957,8 +957,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside , ppr arg , ppr arg_no]) ; setSrcSpanA arg_loc $ - addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ - thing_inside + addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ + thing_inside } | otherwise = do { traceTc "addArgCtxt" (vcat [text "generated Head" @@ -966,8 +966,9 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside , ppr app_head_lspan , ppr arg_loc , ppr arg]) - ; addLExprCtxt (locA arg_loc) arg $ - thing_inside + ; setSrcSpanA arg_loc $ + addExprCtxt arg $ + thing_inside } @@ -2012,17 +2013,21 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ , eaql_res_rho = app_res_rho }) }}} -mk_origin :: SrcSpan -- SrcSpan of the argument +mk_origin :: SrcSpan -- SrcSpan of the function -> HsExpr GhcRn -- The head of the expression application chain -> TcM CtOrigin mk_origin fun_lspan rn_fun | not (isGeneratedSrcSpan fun_lspan) = return $ exprCtOrigin rn_fun - | otherwise -- if the location is generated, - -- the best we can do is to approximate by looking on top of the error message stack - = do { code_orig <- getHsCtxt - ; traceTc "mk_origin" (pprHsCtxt code_orig) - ; return $ hsCtxtCtOrigin code_orig + + | otherwise -- If the location is generated, the best we can do is to + -- approximate by looking on top of the error message stack + = do { err_ctxt_stack <- getErrCtxt + ; let hs_ctxt = case err_ctxt_stack of + (c:_) -> c + [] -> pprPanic "mk_origin" (ppr rn_fun) + ; traceTc "mk_origin" (pprHsCtxt hs_ctxt) + ; return $ hsCtxtCtOrigin hs_ctxt } ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -122,7 +122,8 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -250,9 +251,11 @@ tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr Ghc tcInferExpr = tc_infer_expr IFRR_Any tcInferExprNC = tc_infer_expr_NC IFRR_Any -tc_infer_expr, tc_infer_expr_NC :: InferFRRFlag -> InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) +tc_infer_expr, tc_infer_expr_NC :: InferFRRFlag -> InferInstFlag + -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) tc_infer_expr ifrr iif (L loc expr) - = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- runInfer iif ifrr (tcExpr expr) ; return (L loc expr', rho) } @@ -278,9 +281,10 @@ tcMonoLExpr, tcMonoLExprNC -> TcM (LHsExpr GhcTc) tcMonoLExpr (L loc expr) res_ty - = do addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } tcMonoLExprNC (L loc expr) res_ty = setSrcSpanA loc $ @@ -813,9 +817,9 @@ The rest of this Note explains how that is done. where `ee` is the expansion of the user written thing `ue` * The type checker context has 3 key fields that describe the context: - TcLclCtxt { tcl_loc :: RealSrcSpan + TcLclCtxt { tcl_loc :: RealSrcSpan , tcl_in_gen_code :: Bool - , tcl_err_ctxt :: [ErrCtxt] + , tcl_err_ctxt :: ErrCtxtStack , ... } Note `tcl_loc` always points to a real place in the source code, hence `RealSrcSpan`. @@ -831,24 +835,20 @@ The rest of this Note explains how that is done. * Now, when tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - gets a located expression, it does 2 things: - (a) Calls `addLExprCtxt` to perform error context management - (b) Calls `tcExpr` to typecheck the expression. - -(a) `addLExprCtxt span expr` - (1) updates the location of `tcl_loc` with the `span` above, - (2) adds an `ErrCtxt` on top of the `tcl_err_ctxt`. + gets a located expression, it does 3 things: + (a) Calls `setSrcSpanA` to set the ambient source-code location + (b) Calls `addExprCtxt` to add a suitable `HsCtxt` on top of the `tcl_err_ctxt`. + (c) Calls `tcExpr` to typecheck the expression. -* However, if the `span` is generated (see `isGeneratedSrcSpan`), then - `addLExprCtxt` sets `tcl_in_gen_code` to `True` via a call to `setSrcSpan` - and the `tcl_err_ctxt` is left untouched. Crucially, when we generate code in `expandExpr`, - all the generated AST notes are tagged with a `GeneratedSrcSpan`. This - is how we avoid populating the TcLclCtxt with generated code. +* In these calls, if the `span` is generated (see `isGeneratedSrcSpan`), then + - `setSrcSpanA` sets `tcl_in_gen_code` to `True` + - `addErrCtxt` is a no-op if `tcl_in_gen_code` is True + This is how we avoid populating the TcLclCtxt with generated code. * The type checker error-stack element `GHC.Tc.Types.ErrCtxt.HsCtxt` just stores an error message - type ErrCtxt = HsCtxt + type ErrCtxtStack = [HsCtxt] When called on an `XExpr`, `addLExprCtxt`, adds the user written thing `ue`, and the error message provided by the caller on the `ErrCtxtStack` See ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -473,7 +473,8 @@ tcInferAppHead_maybe fun = case fun of -with_get_ds :: TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType) +with_get_ds :: TcM (HsExpr GhcTc, TcSigmaType) + -> TcM (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType) with_get_ds mthing = do { (expr_tc, sig_ty) <- mthing ; ds_flag <- getDeepSubsumptionFlag_DataConHead expr_tc ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -405,7 +405,7 @@ so that tcPat can extend the environment for the thing_inside, but also so that constraints arising in the thing_inside can be discharged by the pattern. -This does not work so well for the ErrCtxt carried by the monad: we don't +This does not work so well for the HsCtxt carried by the monad: we don't want the error-context for the pattern to scope over the RHS. Hence the getErrCtxt/setErrCtxt stuff in tcMultiple -} ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Tc.Types( FrontendResult(..), -- Renamer types - ErrCtxt, + HsCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, ImportUserSpec(..), ImpUserList(..), ===================================== compiler/GHC/Tc/Types/CtLoc.hs ===================================== @@ -439,7 +439,7 @@ pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) -- when reporting errors, see `setCtLocM`. -- -- See also 'TcLclCtxt'. -data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt] +data CtLocEnv = CtLocEnv { ctl_ctxt :: !ErrCtxtStack , ctl_loc :: !RealSrcSpan , ctl_bndrs :: !TcBinderStack , ctl_tclvl :: !TcLevel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -1,9 +1,10 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt, HsCtxt(..), isHsCtxtLandmark + ( HsCtxt(..), isHsCtxtLandmark , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) + , ErrCtxtStack -- * UserTypeCtxt , UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe @@ -51,6 +52,7 @@ import qualified Data.List.NonEmpty as NE {- ********************************************************************* * * UserTypeCtxt +b * * ********************************************************************* -} @@ -195,19 +197,14 @@ isSigMaybe _ = Nothing {- ********************************************************************* * * - ErrCtxt + HsCtxt + Error message contexts * * ********************************************************************* -} --------------------------------------------------------------------------------- --- type HsCtxtM = TidyEnv -> ZonkM (TidyEnv, HsCtxt) - --- | Additional context to include in an error message, e.g. --- "In the type signature ...", "In the ambiguity check for ...", etc. -type ErrCtxt = HsCtxt - --------------------------------------------------------------------------------- --- Error message contexts +-- An error-context stack (maintained in the typehcecker's monad) +-- is just a stack of HsCtxts +type ErrCtxtStack = [HsCtxt] data UserSigType = UserLHsSigType !(LHsSigType GhcRn) ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,7 +21,6 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvHsCtxt , setLclEnvHsCtxt , setLclCtxtHsCtxt , lclEnvInGeneratedCode @@ -90,34 +89,6 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } -{- - -Note [ErrCtxtStack Manipulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ErrCtxtStack is a list of ErrCtxt - -This data structure keeps track of two things: -1. Are we type checking a compiler generated/non-user written code. -2. The trail of the error messages that have been added in route to the current expression - -* When the `ErrCtxtStack` is a `UserCodeCtxt`, - - the current expression being typechecked is user written -* When the `ErrorCtxtStack` is a `ExpansionCodeCtxt` - - the current expression being typechecked is compiler generated/expanded; - - the original source code thing is stored in `src_code_origin` field. - - the `src_code_origin` is what will be used in the error message displayed to the user - -In the current design, if the top of the ErrCtxtStack is an ExpansionCodeCtxt -i.e. we are currently typechecking a compiler generated expression, and we encounter -an XExpr, then we _replace_ the top of the stack with the new XExpr. Otherwise, we -push the new expression error message on top of the stack. cf. `LclEnv.setLclCtxtHsCtxt` - --} - - --- See Note [ErrCtxtStack Manipulation] -type ErrCtxtStack = [ErrCtxt] - -- | Get the top of the error message stack get_err_ctxt_stack_head :: ErrCtxtStack -> HsCtxt get_err_ctxt_stack_head (e : _) = e @@ -127,7 +98,7 @@ data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span tcl_in_gen_code :: Bool, -- Are we type checking a generated expression? - tcl_err_ctxt :: ErrCtxtStack, -- See Note [ErrCtxtStack Manipulation] + tcl_err_ctxt :: ErrCtxtStack, tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -191,26 +162,23 @@ setLclEnvLoc loc = modifyLclCtxt (\lenv -> lenv { tcl_loc = loc }) getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt -getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] +getLclEnvErrCtxt :: TcLclEnv -> ErrCtxtStack getLclEnvErrCtxt = tcl_err_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) -- See Note [ErrCtxtStack Manipulation] -addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +addLclEnvErrCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv addLclEnvErrCtxt ec = setLclEnvHsCtxt ec -getLclEnvHsCtxt :: TcLclEnv -> HsCtxt -getLclEnvHsCtxt = get_err_ctxt_stack_head . tcl_err_ctxt . tcl_lcl_ctxt - -setLclEnvHsCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +setLclEnvHsCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv setLclEnvHsCtxt ec = modifyLclCtxt (setLclCtxtHsCtxt ec) -- See Note [ErrCtxtStack Manipulation] -setLclCtxtHsCtxt :: ErrCtxt -> TcLclCtxt -> TcLclCtxt +setLclCtxtHsCtxt :: HsCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtHsCtxt ec lclCtxt - -- never stack 2 statement error contexts on top of each other + -- Never stack 2 statement error contexts on top of each other | StmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt , StmtErrCtxt{} <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -61,7 +61,6 @@ module GHC.Tc.Utils.Monad( addDependentFiles, addDependentDirectories, -- * Error management - getHsCtxt, getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -88,7 +87,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, - addLExprCtxt, + addExprCtxt, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) @@ -98,7 +97,7 @@ module GHC.Tc.Utils.Monad( checkTc, checkTcM, checkJustTc, checkJustTcM, failIfTc, failIfTcM, - mkErrCtxt, + tidyErrCtxt, addTcRnDiagnostic, addDetailedDiagnostic, mkTcRnMessage, reportDiagnostic, reportDiagnostics, warnIf, diagnosticTc, diagnosticTcM, @@ -1086,7 +1085,15 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] --- NB: This is the only place where tcl_in_gen_code is modified +-- When entering a node decorated with a /user/ span: +-- * Record that span in `tcl_loc` +-- * Set `tcl_in_gen_code` to False, to record that we +-- are in user code. +-- When entering a node decorated with a /generated/ span: +-- * Do not touch `tcl_loc`, so that `tcl_loc` always records +-- the innermost user span. +-- NB: This is the only place where `tcl_loc` and `tcl_in_gen_code` +-- are modified setSrcSpan (RealSrcSpan loc _) thing_inside = updLclCtxt (\ctxt -> ctxt {tcl_loc = loc, tcl_in_gen_code = False}) thing_inside setSrcSpan (GeneratedSrcSpan{}) thing_inside @@ -1094,9 +1101,6 @@ setSrcSpan (GeneratedSrcSpan{}) thing_inside setSrcSpan _ thing_inside = thing_inside -getHsCtxt :: TcRn HsCtxt -getHsCtxt = getLclEnvHsCtxt <$> getLclEnv - setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1177,7 +1181,7 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- liftZonkM $ tcInitTidyEnv - ; err_ctxt <- mkErrCtxt tidy_env ctxt + ; err_ctxt <- tidyErrCtxt tidy_env ctxt ; let detailed_msg = mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg ; add_long_err_at loc detailed_msg } @@ -1314,57 +1318,49 @@ problem. Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* setSrcSpan is the only place that modifies `tcl_in_gen_code` +* setSrcSpan is the only place that modifies `tcl_loc` and `tcl_in_gen_code` -* addLExpr updates updates the ErrCtxt stored in LclEnv with the following logic - - If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc` to the given value - and sets `tcl_in_gen_code` to `False`. Meaning we are not type checking a compiler generated - expression. And thus it can add the expression on to the ErrCtxt Stack - - If the `SrcSpan` is a GeneratedSrcSpan then `tcl_in_gen_code` is set to `True`, meaning - the expression in hand is compiler generated, and hence it is not added on to the stack. +* addLExpr updates updates the HsCtxt stored in LclEnv with the following logic + - If `tcl_in_gen_code` is true, do nothing + - Otherwise push a suitable HsCtxt onto the ErrCtxtStack This ensures that the error messages do not leak compiler generated expressions which can be confusing to the users as they never appear in the original source code - - See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for -more discussion of this fancy footwork + more discussion of this fancy footwork - See Note [Generated code and pattern-match checking] in `GHC.Types.Basic` for the -relation with pattern-match checks -- See Note [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack` + relation with pattern-match checks -} -- See Note [Error contexts in generated code] -addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a -addLExprCtxt lspan e thing_inside - = setSrcSpan lspan $ add_expr_ctxt e thing_inside - where - add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a - add_expr_ctxt e thing_inside - = do { igc <- inGeneratedCode - ; if igc -- generated - then thing_inside - else case e of - -- The HsHole special case addresses situations like - -- f x = _ - -- when we don't want to say "In the expression: _", - -- because it is mentioned in the error message itself - HsHole{} -> thing_inside - - -- There is a special case for expressions with signatures to avoid having too verbose - -- error context. c.f. RecordDotSyntaxFail9 - -- Add the original HsCtxt if we are typechecking an expanded expression - ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside - XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside - - _ -> addErrCtxt (ExprCtxt e) thing_inside - } - -getErrCtxt :: TcM [ErrCtxt] +addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside + = do { igc <- inGeneratedCode + ; if igc -- In generated code; so addExprCtxt is a no-op + then thing_inside + else case e of + -- The HsHole special case addresses situations like + -- f x = _ + -- when we don't want to say "In the expression: _", + -- because it is mentioned in the error message itself + HsHole{} -> thing_inside + + -- There is a special case for expressions with signatures to avoid having + -- too verbose error context. c.f. RecordDotSyntaxFail9 + -- Add the original HsCtxt if we are typechecking an expanded expression + ExprWithTySig _ (L _ e') _ + | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside + + XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside + + _ -> addErrCtxt (ExprCtxt e) thing_inside + } + +getErrCtxt :: TcM ErrCtxtStack getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +setErrCtxt :: ErrCtxtStack -> TcM a -> TcM a {-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) @@ -1374,7 +1370,7 @@ addErrCtxt :: HsCtxt -> TcM a -> TcM a addErrCtxt ctxt = pushCtxt ctxt -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -pushCtxt :: ErrCtxt -> TcM a -> TcM a +pushCtxt :: HsCtxt -> TcM a -> TcM a {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] pushCtxt ctxt = updLclEnv (addLclEnvErrCtxt ctxt) @@ -1868,7 +1864,7 @@ addDiagnosticTc msg addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () addDiagnosticTcM (env0, msg) = do { ctxt <- getErrCtxt - ; extra <- mkErrCtxt env0 ctxt + ; extra <- tidyErrCtxt env0 ctxt ; let detailed_msg = mkDetailedMessage (ErrInfo extra Nothing noHints) msg ; add_diagnostic detailed_msg } @@ -1881,7 +1877,7 @@ addDetailedDiagnostic mkMsg = do !diag_opts <- initDiagOpts <$> getDynFlags env0 <- liftZonkM tcInitTidyEnv ctxt <- getErrCtxt - err_info <- mkErrCtxt env0 ctxt + err_info <- tidyErrCtxt env0 ctxt reportDiagnostic $ mkMsgEnvelope diag_opts loc name_ppr_ctx $ mkMsg err_info @@ -1918,16 +1914,19 @@ add_diagnostic msg -} add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan - -> [ErrCtxt] + -> ErrCtxtStack -> TcM () add_err_tcm tidy_env msg loc ctxt - = do { err_ctxt <- mkErrCtxt tidy_env ctxt + = do { err_ctxt <- tidyErrCtxt tidy_env ctxt ; add_long_err_at loc $ mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg } -mkErrCtxt :: TidyEnv -> [ErrCtxt] -> TcM [HsCtxt] --- Tidy the error info, trimming excessive contexts -mkErrCtxt env ctxts +tidyErrCtxt :: TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack +-- Do the following +-- * Zonk each HsCtxt in the ErrCtxtStack +-- * Tidy each using TidyEnv +-- * Trim excessive contexts +tidyErrCtxt env ctxts -- = do -- dbg <- hasPprDebug <$> getDynFlags -- if dbg -- In -dppr-debug style the output @@ -1935,7 +1934,7 @@ mkErrCtxt env ctxts -- else go dbg 0 env ctxts = go False 0 env ctxts -- regular error ctx where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [HsCtxt] + go :: Bool -> Int -> TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack go _ _ _ [] = return [] go dbg n env (ctxt : ctxts) | isHsCtxtLandmark ctxt ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -2698,11 +2698,11 @@ uType_defer (UE { u_loc = loc, u_defer = ref -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality -- Error trace only - -- NB. do *not* call mkErrCtxt unless tracing is on, + -- NB. do *not* call tidyErrCtxt unless tracing is on, -- because it is hugely expensive (#5631) ; whenDOptM Opt_D_dump_tc_trace $ do { ctxt <- getErrCtxt - ; err_ctxt <- mkErrCtxt emptyTidyEnv ctxt + ; err_ctxt <- tidyErrCtxt emptyTidyEnv ctxt ; traceTc "utype_defer" $ vcat ( ppr role : debugPprType ty1 ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -798,6 +798,8 @@ tidyEvVar env var = updateIdTypeAndMult (tidyType env) var zonkTidyHsCtxt :: TidyEnv -> HsCtxt -> ZonkM (TidyEnv, HsCtxt) +-- We zonk and tidy a HsCtxt just before putting it into an error message +-- so that it contains as much info as possible, as tidily as possible zonkTidyHsCtxt env e@(ExprCtxt{}) = return (env, e) zonkTidyHsCtxt env (ThetaCtxt ctxt theta_ty) = do (env', theta_ty') <- zonkTidyTcTypes env theta_ty ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -152,7 +152,7 @@ I.1. GHC.Tc.Zonk.Monad - the ZonkM monad as used in GHC.Tc.Zonk.TcType. Crucially, it never errors. It is the monad we use when reporting errors - (see ErrCtxt), and it would be quite bad if we could error in the middle + (see HsCtxt), and it would be quite bad if we could error in the middle of reporting an error! I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b99e8e72978299dc8de3a1b8a0ab95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b99e8e72978299dc8de3a1b8a0ab95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/validate-fix-werror] 8 commits: Add support for custom external interpreter commands
by Cheng Shao (＠TerrorJack) 22 Mar '26

22 Mar '26

Cheng Shao pushed to branch wip/validate-fix-werror at Glasgow Haskell Compiler / GHC Commits: 18513365 by Matthew Pickering at 2026-03-21T04:43:26-04:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 4636d906 by mangoiv at 2026-03-21T04:44:10-04:00 ci: remove obsolete fallback for old debian and ubuntu versions - - - - - 2e3a2805 by mangoiv at 2026-03-21T04:44:10-04:00 ci: drop ubuntu 18 and 20 Ubuntu 18 EOL: May 2023 Ubuntu 20 EOL: May 2025 We should probably not make another major release supporting these platforms. Also updates the generator script. Resolves #25876 - - - - - de54e264 by Cheng Shao at 2026-03-21T17:52:08+01:00 rts: fix -Wcompare-distinct-pointer-types errors This commit fixes `-Wcompare-distinct-pointer-types` errors in the RTS which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. - - - - - b9bd73de by Cheng Shao at 2026-03-21T17:52:08+01:00 ghc-internal: fix unused imports This commit fixes unused imports in `ghc-internal` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - da946a16 by Cheng Shao at 2026-03-21T17:03:51+00:00 ghci: fix unused imports This commit fixes unused imports in `ghci` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - 955b1cf8 by Cheng Shao at 2026-03-21T17:03:51+00:00 compiler: fix unused imports in GHC.Tc.Types.Origin This commit fixes unused imports in `GHC.Tc.Types.Origin` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #27059. - - - - - 3b1aeb50 by Cheng Shao at 2026-03-21T17:03:51+00:00 hadrian: fix missing +werror in validate flavour This patch fixes missing `+werror` in validate flavour, which was an oversight in bb3a2ba1eefadf0b2ef4f39b31337a23eec67f29. Fixes #27066. - - - - - 30 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/flake.lock - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Tc/Types/Origin.hs - docs/users_guide/utils.py - hadrian/src/Settings/Flavours/Validate.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - rts/Interpreter.c - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1212,10 +1212,6 @@ ghcup-metadata-nightly: artifacts: false - job: nightly-x86_64-linux-ubuntu22_04-validate artifacts: false - - job: nightly-x86_64-linux-ubuntu20_04-validate - artifacts: false - - job: nightly-x86_64-linux-ubuntu18_04-validate - artifacts: false - job: nightly-x86_64-linux-rocky8-validate artifacts: false - job: nightly-x86_64-darwin-validate ===================================== .gitlab/generate-ci/flake.lock ===================================== @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1710146030, - "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -20,12 +20,10 @@ }, "nixpkgs": { "locked": { - "lastModified": 1724334015, - "narHash": "sha256-5sfvc0MswIRNdRWioUhG58rGKGn2o90Ck6l6ClpwQqA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6d204f819efff3d552a88d0a44b5aaaee172b784", - "type": "github" + "lastModified": 0, + "narHash": "sha256-M0yS4AafhKxPPmOHGqIV0iKxgNO8bHDWdl1kOwGBwRY=", + "path": "/nix/store/nbylyyw8k98a0an6p6nz0hvk5psygwb8-source", + "type": "path" }, "original": { "id": "nixpkgs", ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -122,8 +122,6 @@ data LinuxDistro | Ubuntu2404LoongArch64 | Ubuntu2404 | Ubuntu2204 - | Ubuntu2004 - | Ubuntu1804 | Alpine312 | Alpine323 | AlpineWasm @@ -326,8 +324,6 @@ distroName Debian13Riscv = "deb13-riscv" distroName Debian12Wine = "deb12-wine" distroName Fedora43 = "fedora43" distroName Ubuntu2404LoongArch64 = "ubuntu24_04-loongarch" -distroName Ubuntu1804 = "ubuntu18_04" -distroName Ubuntu2004 = "ubuntu20_04" distroName Ubuntu2204 = "ubuntu22_04" distroName Ubuntu2404 = "ubuntu24_04" distroName Alpine312 = "alpine3_12" @@ -1193,9 +1189,7 @@ debian_i386 = ubuntu_x86 :: [JobGroup Job] ubuntu_x86 = - [ disableValidate (standardBuilds Amd64 (Linux Ubuntu1804)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2004)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) + [ disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) , disableValidate (standardBuilds Amd64 (Linux Ubuntu2404)) ] ===================================== .gitlab/jobs.yaml ===================================== @@ -3385,132 +3385,6 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-ubuntu18_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate", - "XZ_OPT": "-9" - } - }, - "nightly-x86_64-linux-ubuntu20_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate", - "XZ_OPT": "-9" - } - }, "nightly-x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -5192,134 +5066,6 @@ "XZ_OPT": "-9" } }, - "release-x86_64-linux-ubuntu18_04-release": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "1 year", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-release", - "BUILD_FLAVOUR": "release", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "IGNORE_PERF_FAILURES": "all", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-release", - "XZ_OPT": "-9" - } - }, - "release-x86_64-linux-ubuntu20_04-release": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "1 year", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-release", - "BUILD_FLAVOUR": "release", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "IGNORE_PERF_FAILURES": "all", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-release", - "XZ_OPT": "-9" - } - }, "release-x86_64-linux-ubuntu22_04-release": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -7472,130 +7218,6 @@ "TEST_ENV": "x86_64-linux-rocky8-validate" } }, - "x86_64-linux-ubuntu18_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu18_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate" - } - }, - "x86_64-linux-ubuntu20_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu20_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate" - } - }, "x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -21,8 +21,6 @@ def job_triple(job_name): 'release-x86_64-linux-rocky8-release': 'x86_64-rocky8-linux', 'release-x86_64-linux-ubuntu24_04-release': 'x86_64-ubuntu24_04-linux', 'release-x86_64-linux-ubuntu22_04-release': 'x86_64-ubuntu22_04-linux', - 'release-x86_64-linux-ubuntu20_04-release': 'x86_64-ubuntu20_04-linux', - 'release-x86_64-linux-ubuntu18_04-release': 'x86_64-ubuntu18_04-linux', 'release-x86_64-linux-fedora43-release': 'x86_64-fedora43-linux', 'release-x86_64-linux-fedora43-release+debug_info': 'x86_64-fedora43-linux-dwarf', 'release-x86_64-linux-deb13-release': 'x86_64-deb13-linux', ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -195,8 +195,6 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform)) # Here are all the bindists we can distribute - ubuntu1804 = mk(ubuntu("18_04")) - ubuntu2004 = mk(ubuntu("20_04")) ubuntu2204 = mk(ubuntu("22_04")) ubuntu2404 = mk(ubuntu("24_04")) rocky8 = mk(rocky("8")) @@ -227,15 +225,13 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): , "( >= 12 && < 13 )": deb12 , ">= 13": deb13 , "unknown_versioning": deb11 } - , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2004 - , "( >= 18 && < 19 )": ubuntu1804 - , "( >= 19 && < 21 )": ubuntu2004 - , "( >= 21 && < 24 )": ubuntu2204 + , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2204 + , "( < 24 )": ubuntu2204 , "( >= 24 )": ubuntu2404 } - , "Linux_Mint" : { "< 20": ubuntu1804 - , ">= 20": ubuntu2004 - , "unknown_versioning": ubuntu2004 } + , "Linux_Mint" : { "< 24": ubuntu2204 + , ">= 24": ubuntu2404 + , "unknown_versioning": ubuntu2204 } , "Linux_CentOS" : { "( >= 8 && < 9 )" : rocky8 , "unknown_versioning" : rocky8 } , "Linux_Fedora" : { ">= 43": fedora43 ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -83,7 +83,6 @@ import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import qualified Data.Semigroup as Semi -import GHC.Generics {- ********************************************************************* * * ===================================== docs/users_guide/utils.py ===================================== @@ -1,11 +1,6 @@ from docutils import nodes -# N.B. `packaging` is not available in Ubuntu 18.04 or Debian 9 -# See #23818. -try: - from packaging.version import parse as parse_version -except ImportError as e: - from distutils.version import LooseVersion as parse_version +from packaging.version import parse as parse_version # Taken from Docutils source inside the ListTable class. We must bypass # using the class itself, but this function comes in handy. ===================================== hadrian/src/Settings/Flavours/Validate.hs ===================================== @@ -8,7 +8,7 @@ import {-# SOURCE #-} Settings.Default -- Please update doc/flavours.md when changing this file. validateFlavour :: Flavour -validateFlavour = enableLinting $ quickValidateFlavour +validateFlavour = enableLinting $ werror $ quickValidateFlavour { name = "validate" , extraArgs = validateArgs <> defaultHaddockExtraArgs , ghcDebugAssertions = (<= Stage1) ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Internal.Conc.IO #endif ) where -import GHC.Internal.Base (otherwise, pure, return, ($)) +import GHC.Internal.Base (otherwise, return, ($)) import GHC.Internal.Conc.Sync as Sync import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.STM as STM @@ -82,6 +82,10 @@ import qualified GHC.Internal.Wasm.Prim.Conc as Wasm import qualified GHC.Internal.Wasm.Prim.Flag as Wasm #endif +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + ensureIOManagerIsRunning :: IO () #if defined(javascript_HOST_ARCH) ensureIOManagerIsRunning = pure () ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Control.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Internal.Event.Control #include <ghcplatform.h> #include "EventConfig.h" -import GHC.Internal.Base (fmap, otherwise, pure, return, when, ($), (.)) +import GHC.Internal.Base (fmap, otherwise, return, when, ($), (.)) import GHC.Internal.Classes (Eq(..), (&&)) import GHC.Internal.IORef import GHC.Internal.Conc.Signal (Signal) @@ -56,6 +56,10 @@ import GHC.Internal.Foreign.C.Types (CULLong(..)) import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF) #endif +#if defined(wasm32_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc ===================================== @@ -33,7 +33,7 @@ import GHC.Internal.Data.Bits (Bits(..), FiniteBits(..)) import GHC.Internal.Err (errorWithoutStackTrace, undefined) import GHC.Internal.Int import GHC.Internal.Data.Maybe (Maybe(..), catMaybes) -import GHC.Internal.Types (Bool(..), Int, IO) +import GHC.Internal.Types (Bool(..), IO) import GHC.Internal.Word (Word16, Word32) import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, eNOTSUP, getErrno, throwErrno) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -185,12 +185,12 @@ import GHC.Internal.Prim ( decodeFloat_Int#, divideFloat#, double2Float#, eqWord#, expDouble#, expFloat#, expm1Double#, expm1Float#, fabsDouble#, fabsFloat#, float2Double#, geFloat#, gtFloat#, gtWord#, int2Float#, int2Double#, - int2Word#, int64ToInt#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, + int2Word#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, logFloat#, ltFloat#, ltWord#, minusFloat#, minusWord#, negateDouble#, negateFloat#, negateInt#, plusFloat#, powerFloat#, sinDouble#, sinFloat#, sinhDouble#, sinhFloat#, sqrtDouble#, sqrtFloat#, tanDouble#, tanFloat#, tanhDouble#, tanhFloat#, timesFloat#, uncheckedIShiftRA#, uncheckedShiftL#, - word2Float#, word2Double#, word2Int#, word64ToWord#, + word2Float#, word2Double#, word2Int#, (+#), (+##), (-#), (-##), (*##), (**##), (/##), (<#), (<##), (<=#), (<=##), (>#), (>##), (>=#), (>=##), ) @@ -206,6 +206,13 @@ import GHC.Internal.Float.RealFracMethods import GHC.Internal.Float.ConversionUtils import GHC.Internal.Bignum.BigNat +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Prim ( + int64ToInt#, + word64ToWord#, + ) +#endif + infixr 8 ** -- $setup ===================================== libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Num () -- instance Num Integer -- (We could remove uses with a little effort) import GHC.Internal.Prim ( - Int#, eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, + eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, int2Double#, int2Word#, ltFloat#, minusFloat#, negateFloat#, negateDouble#, negateInt#, uncheckedIShiftL#, uncheckedIShiftRA#, uncheckedIShiftRL#, (+#), (-#), (<#), (>#), (-##), (==##), (<##), @@ -86,6 +86,10 @@ import GHC.Internal.Prim ( #else +import GHC.Internal.Prim ( + Int#, + ) + #define TO64 integerToInt# #define FROM64 IS #define MINUS64 ( -# ) @@ -355,4 +359,3 @@ foreign import ccall unsafe "rintDouble" foreign import ccall unsafe "rintFloat" c_rintFloat :: Float -> Float - ===================================== libraries/ghc-internal/src/GHC/Internal/IO/FD.hs ===================================== @@ -30,7 +30,7 @@ module GHC.Internal.IO.FD ( ) where import GHC.Internal.Base ( - String, fmap, id, otherwise, pure, return, when, ($), (.), (++), (>>=), + String, fmap, otherwise, pure, return, when, ($), (.), (++), (>>=), ) import GHC.Internal.Bits import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) @@ -58,6 +58,10 @@ import GHC.Internal.Err (error) import GHC.Internal.Windows import GHC.Internal.IO.SubSystem ((<!>)) import GHC.Internal.Foreign.Storable +#else +import GHC.Internal.Base ( + id, + ) #endif import GHC.Internal.Foreign.C.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Int.hs ===================================== @@ -51,7 +51,7 @@ import GHC.Internal.Classes ( Eq(..), Ord(..), eqInt, neInt, gtInt, geInt, ltInt, leInt, divInt8#, divInt16#, divInt32#, - divModInt8#, divModInt16#, divModInt32#, divModInt#, + divModInt8#, divModInt16#, divModInt32#, modInt8#, modInt16#, modInt32#, (&&), (||), ) @@ -63,6 +63,12 @@ import GHC.Internal.Arr import GHC.Internal.Show import GHC.Internal.Types (Bool(..), Float, Double, Int(..), isTrue#) +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Classes ( + divModInt#, + ) +#endif + ------------------------------------------------------------------------ -- type Int8 ------------------------------------------------------------------------ ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Ptr import GHC.Internal.Types (Bool(..), Double, Int) import GHC.Internal.Word import GHC.Internal.Base ( - String, otherwise, pure, return, (.), (++), (<*>), (=<<), + String, otherwise, return, (.), (++), (<*>), (=<<), ) import GHC.Internal.Enum import GHC.Internal.Generics (Generic) @@ -74,6 +74,10 @@ import GHC.Internal.IO import GHC.Internal.Real import GHC.Internal.Show +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + -- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- -- @since base-4.8.2.0 ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc ===================================== @@ -8,16 +8,20 @@ module GHC.Internal.RTS.Flags.Test ) where -import GHC.Internal.Base (pure) import GHC.Internal.Ptr -import GHC.Internal.Foreign.C.Types -import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import GHC.Internal.Data.Functor ((<$>)) import GHC.Internal.Types (Bool(..), Int, IO) import GHC.Internal.Word (Word32) import GHC.Internal.Real (fromIntegral) +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#else +import GHC.Internal.Foreign.C.Types +import GHC.Internal.Foreign.Marshal.Utils +#endif + #include "Rts.h" #include "rts/Flags.h" ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment.hs ===================================== @@ -49,9 +49,13 @@ import GHC.Internal.Base (fmap) import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Control.Exception.Base (bracket) import GHC.Internal.Err (undefined) +#else +import GHC.Internal.Base ( + map, (++), + ) #endif import GHC.Internal.Base ( - String, liftM, map, mapM, otherwise, return, ($), (.), (++), (>>=), + String, liftM, mapM, otherwise, return, ($), (.), (>>=), ) import GHC.Internal.List (null, elem, takeWhile, break) import GHC.Internal.Maybe (Maybe(..)) ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc ===================================== @@ -43,7 +43,7 @@ import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Data.Functor import GHC.Internal.Data.List (elem, null, takeWhile) import GHC.Internal.Foreign.C.String -import GHC.Internal.Base (String, otherwise, return, ($)) +import GHC.Internal.Base (String, otherwise, ($)) #if defined(mingw32_HOST_OS) import GHC.Internal.Base ((.)) import GHC.Internal.Foreign.Ptr @@ -51,6 +51,7 @@ import GHC.Internal.Windows import GHC.Internal.Control.Monad import GHC.Internal.Data.List (lookup) #else +import GHC.Internal.Base (return) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Real (fromIntegral) ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -249,6 +249,7 @@ import GHC.Internal.Base (String, failIO, otherwise, return, ($), (.), (>>=)) import GHC.Internal.List #if !defined(mingw32_HOST_OS) import GHC.Internal.IORef +import GHC.Internal.Types (Int) #endif import GHC.Internal.Num import GHC.Internal.IO hiding ( bracket, onException ) @@ -262,7 +263,7 @@ import GHC.Internal.IO.Encoding import GHC.Internal.Text.Read import GHC.Internal.IO.StdHandles import GHC.Internal.Show -import GHC.Internal.Types (Bool(..), Char, Int) +import GHC.Internal.Types (Bool(..), Char) ----------------------------------------------------------------------------- -- Standard IO ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -46,19 +46,20 @@ import GHC.Internal.Data.Maybe #if !defined(HTYPE_TCFLAG_T) import GHC.Internal.System.IO.Error +#if !defined(mingw32_HOST_OS) +import GHC.Internal.Err (errorWithoutStackTrace) +#endif #endif import GHC.Internal.Base ( String, otherwise, pure, return, when, ($), (++), (>>=), ) import GHC.Internal.Bits -import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) -import GHC.Internal.CString (cstringLength#) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Classes (Eq(..), not, (&&), (||)) import GHC.Internal.Num import GHC.Internal.Prim (yield#) import GHC.Internal.Real -import GHC.Internal.Types (Bool(..), Int(..)) +import GHC.Internal.Types (Bool(..)) import GHC.Internal.Word import GHC.Internal.IO import GHC.Internal.IO.IOMode @@ -71,10 +72,13 @@ import GHC.Internal.Int (Int64) #endif #if !defined(mingw32_HOST_OS) +import GHC.Internal.CString (cstringLength#) +import GHC.Internal.Classes (Ord(..)) import {-# SOURCE #-} GHC.Internal.IO.Encoding (getFileSystemEncoding) import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import qualified GHC.Internal.Foreign.C.String.Encoding as GHC +import GHC.Internal.Types (Int(..)) #else import GHC.Internal.Int import GHC.Internal.Data.OldList (elem) ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -39,12 +39,12 @@ module GHC.Internal.TopHandler ( import GHC.Internal.Control.Exception import GHC.Internal.Data.Maybe -import GHC.Internal.Classes (Eq(..), Ord(..), (&&)) +import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String import GHC.Internal.Base ( - String, const, failIO, otherwise, pure, return, ($), (++), (>>), + String, failIO, return, ($), (++), (>>), ) import GHC.Internal.Conc.Sync hiding (throwTo) import GHC.Internal.Prim (Weak#, seq) @@ -67,6 +67,17 @@ import GHC.Internal.Conc.Signal import GHC.Internal.Data.Dynamic (toDyn) #endif +#if !defined(HAVE_SIGNAL_H) +import GHC.Internal.Base (pure) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH) +import GHC.Internal.Base ( + const, otherwise, + ) +import GHC.Internal.Classes (Ord(..), (&&)) +#endif + -- Note [rts_setMainThread must be called unsafely] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- rts_setMainThread must be called as unsafe, because it ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -246,6 +246,11 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) + -- | User-defined request encoded as a tag/payload pair. This is left + -- uninterpreted by GHC and is meant for GHC API applications to be able to supply + -- their own interpreter which understands additional commands. + CustomMessage :: Word8 -> ByteString -> Message ByteString + deriving instance Show (Message a) -- | Used to dynamically create a data constructor's info table at @@ -602,6 +607,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +654,7 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a + CustomMessage tag payload -> putWord8 41 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -125,6 +125,7 @@ run m = case m of Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m + CustomMessage {} -> unexpectedMessage m unexpectedMessage :: Message a -> b unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m) ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,7 +1,11 @@ {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server - ( serv + ( MessageHook + , CustomMessageHandler + , serv + , servWithCustom , defaultServer + , defaultServerWithCustom ) where @@ -10,8 +14,8 @@ import GHCi.Run import GHCi.Signals import GHCi.TH import GHCi.Message -#if defined(wasm32_HOST_ARCH) import Data.ByteString (ByteString) +#if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -36,11 +40,27 @@ import System.IO type MessageHook = Msg -> IO Msg +-- | How to interpret the 'CustomCommand'. +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString) + +noCustomHandler :: CustomMessageHandler +noCustomHandler _ _ = return Nothing + trace :: String -> IO () trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe restore = loop +serv verbose hook pipe restore = + servWithCustom verbose hook pipe restore noCustomHandler + +servWithCustom + :: Bool + -> MessageHook + -> Pipe + -> (forall a .IO a -> IO a) + -> CustomMessageHandler + -> IO () +servWithCustom verbose hook pipe restore customHandler = loop where loop = do when verbose $ trace "reading pipe..." @@ -50,6 +70,7 @@ serv verbose hook pipe restore = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs @@ -61,6 +82,13 @@ serv verbose hook pipe restore = loop writePipe pipe (put r) loop + handleCustom tag payload = do + mresp <- customHandler tag payload + case mresp of + Just resp -> reply resp + Nothing -> + error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + -- Run some TH code, which may interact with GHC by sending -- THMessage requests, and then finally send RunTHDone followed by a -- QResult. For an overview of how TH works with Remote GHCi, see @@ -109,12 +137,24 @@ serv verbose hook pipe restore = loop -- | Default server #if defined(wasm32_HOST_ARCH) defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO () -defaultServer cb_sig cb_recv cb_send = do +defaultServer cb_sig cb_recv cb_send = + defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler + +defaultServerWithCustom + :: Callback (JSVal -> IO ()) + -> Callback (IO JSUint8Array) + -> Callback (JSUint8Array -> IO ()) + -> CustomMessageHandler + -> IO () +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do args <- getArgs let rest = args #else defaultServer :: IO () -defaultServer = do +defaultServer = defaultServerWithCustom noCustomHandler + +defaultServerWithCustom :: CustomMessageHandler -> IO () +defaultServerWithCustom customHandler = do args <- getArgs (outh, inh, rest) <- case args of @@ -152,7 +192,7 @@ defaultServer = do putStrLn "Waiting 3s" threadDelay 3000000 - uninterruptibleMask $ serv verbose hook pipe + uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because ===================================== rts/Interpreter.c ===================================== @@ -718,7 +718,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + else if(Sp_plusW(offset_words) < (void*)(cur_stack->stack + cur_stack->stack_size)) { // Still inside the stack chunk return Sp_plusW(offset_words); } else { @@ -2469,7 +2469,7 @@ run_BCO: threadStackUnderflow(cap, cap->r.rCurrentTSO); LOAD_STACK_POINTERS; by -= sp_to_uf; - } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + } else if (Sp_plusW(by) < (void*)(stk->stack + stk->stack_size)) { // we're within the first stack chunk, this chunk has // no underflow frame break; ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-} +module Main (main) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Word (Word8) +import GHCi.Message + ( Message(..) + , mkPipeFromHandles + , remoteCall + , Pipe + ) +import GHCi.Server + ( CustomMessageHandler + , defaultServerWithCustom + ) +import System.Environment + ( getArgs + , getExecutablePath + , getProgName + , withArgs + ) +import System.Exit (exitFailure) +import System.IO + ( Handle + , BufferMode(..) + , hSetBuffering + , hSetBinaryMode + , hClose + , hPutStrLn + , stderr + ) +import System.Posix.IO + ( createPipe + , fdToHandle + , setFdOption + , FdOption(CloseOnExec) + ) +import System.Process + ( createProcess + , proc + , std_in + , std_out + , std_err + , StdStream(Inherit) + , terminateProcess + , waitForProcess + , ProcessHandle + ) +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +-- Shared request/response definitions and helpers + +data ClientCommand a where + SquareCommand :: Int -> ClientCommand Int + MulCommand :: Int -> Int -> ClientCommand Int + +deriving instance (Show (ClientCommand a)) + +data Some c f where + Some :: c a => f a -> Some c f + + +instance Bin.Binary (Some Bin.Binary ClientCommand) where + put (Some i) = + case i of + SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n + MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n + + get = do + (tag :: Word8) <- Bin.get + fmap Some $ case tag of + 0 -> SquareCommand <$> Bin.get + 1 -> MulCommand <$> Bin.get <*> Bin.get + + +customTag :: Word8 +customTag = 0x42 + +encodeLazy :: Bin.Binary a => a -> BS.ByteString +encodeLazy = BL.toStrict . Bin.encode + +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a +decodeLazy bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +-------------------------------------------------------------------------------- +-- Mode selection + +data Mode + = RunClient Int + | RunServer [String] -- forwarded to GHCi.Server + +defaultInput :: Int +defaultInput = 12 + +parseMode :: [String] -> Either String Mode +parseMode [] = Right (RunClient defaultInput) +parseMode ["client"] = Right (RunClient defaultInput) +parseMode ["client", nStr] = + case readMaybe nStr of + Just n -> Right (RunClient n) + Nothing -> Left $ "Unable to parse integer argument: " ++ nStr +parseMode ("client":_) = Left "Too many arguments for client mode." +parseMode ("server":rest) = Right (RunServer rest) +parseMode args = Left "Unknown mode, use client/server" + +usage :: IO () +usage = do + prog <- getProgName + putStrLn $ unlines + [ "Usage:" + , " " ++ prog ++ " [client [n]] Run the client and square n (default 12)." + , " " ++ prog ++ " server <write-fd> <read-fd> Run as an iserv process." + ] + +-------------------------------------------------------------------------------- +-- Client/server drivers + +main :: IO () +main = do + args <- getArgs + case parseMode args of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right (RunClient n) -> runClient n + Right (RunServer serverArgs) -> + withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand)) + +handleClientCommand :: ClientCommand a -> IO a +handleClientCommand (SquareCommand n) = pure $ n * n +handleClientCommand (MulCommand n m) = pure $ n * m + + +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a +customMessage pipe c = do + let payload = encodeLazy (Some @Bin.Binary c) + putStrLn $ "Sending: " ++ show c + respBytes <- remoteCall pipe (CustomMessage customTag payload) + case decodeLazy respBytes of + Left err -> error $ "Decode error: " ++ err + Right res -> pure res + + +runClient :: Int -> IO () +runClient input = do + serverExe <- getExecutablePath + withServer serverExe $ \hFromServer hToServer -> do + pipe <- mkPipeFromHandles hFromServer hToServer + res <- customMessage pipe (SquareCommand input) + putStrLn $ "Square returned: " ++ show res + res2 <- customMessage pipe (MulCommand 2 res) + putStrLn $ "Mul returned: " ++ show res2 + +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a +withServer serverExe action = do + (ghcRead, serverWrite) <- createPipe + (serverRead, ghcWrite) <- createPipe + mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead] + let args = ["server", show serverWrite, show serverRead] + (_, _, _, ph) <- createProcess (proc serverExe args) + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + bracket (mkHandles ghcRead ghcWrite) + (\(hFromServer, hToServer) -> do + hClose hFromServer + hClose hToServer + terminateProcess ph + void (waitForProcess ph)) + (\(hFromServer, hToServer) -> action hFromServer hToServer) + where + mkHandles r w = do + hR <- fdToHandle r + hW <- fdToHandle w + mapM_ (`hSetBuffering` NoBuffering) [hR, hW] + mapM_ (`hSetBinaryMode` True) [hR, hW] + pure (hR, hW) + +-------------------------------------------------------------------------------- +-- Custom handler + +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler +customHandler handler tag payload + | tag == customTag = + case decodeLazy payload of + Left err -> do + hPutStrLn stderr $ "Custom handler decode error: " ++ err + pure Nothing + Right (Some @Bin.Binary r) -> do + res <- handler r + pure . Just $ encodeLazy res + | otherwise = pure Nothing ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -0,0 +1,10 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , when(config.cross, skip) + , req_process + , req_interp + , omit_ways(prof_ways) + ], + multimod_compile_and_run, + ['Main.hs', '-package ghci']) ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout ===================================== @@ -0,0 +1,4 @@ +Sending: SquareCommand 12 +Square returned: 144 +Sending: MulCommand 2 144 +Mul returned: 288 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2130e1932e926870622680c69ce5c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2130e1932e926870622680c69ce5c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] Add documentation for new flags
by Simon Peyton Jones (＠simonpj) 21 Mar '26

21 Mar '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 232a7d8a by Simon Peyton Jones at 2026-03-21T15:59:04+00:00 Add documentation for new flags - - - - - 1 changed file: - docs/users_guide/separate_compilation.rst Changes: ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1641,3 +1641,44 @@ using the :ghc-flag:`--show-iface ⟨file⟩` :ref:`mode <modes>`. If there is a .. [1] This is a change in behaviour relative to 6.2 and earlier. + + +.. _known-key-names + +Known-key names +---------------------------------------- + +(This section is relevant only if you are a GHC developer, or you are +modifying the ``base`` package.) + +GHC relies on a few hundred entities (types, classes, and functions) +defined in the libraries ``ghc-internal`` or ``base``. These include the classes +``Num``, ``Show``, etc, the types ``Rational``, ``Ratio`` etc, and much +more. These entities have so-called "known-key" names. + +You can read ``Note [Overview of known-key names]`` in GHC's source code +to understand more. The behaviour of known-key names is controlled by two +flags: + +.. ghc-flag:: -frebindable-known-key-names + :shortdesc: Find known-key names in the current top-level scope + :type: dynamic + :category: + + This flag is off by default. It is typically set when compiling modules + in ``ghc-internal`` or ``base``, and tells GHC to look for a known-key + entity in the current top-level scope. When the flag is un-set, GHC looks + for the module ``base:GHC.KnownKeyNames``, but this module does not exist + when compiling ``ghc-internal`` or ``base``, which is why the flag is needed. + +.. ghc-flag:: -fdefines-known-key-names + :shortdesc: This module defines a known-key name + :type: dynamic + :category: + + This flag is off by default. It should be set when compiling a module + that *defines* a known-key entity. That is how GHC knows that the entity + called "Rational" in this module is *the* known-key ``Rational`` and not + some other random type or class that happens to be called "Rational". + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/232a7d8a15fee7365ed69e6897b88b8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/232a7d8a15fee7365ed69e6897b88b8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Add support for custom external interpreter commands
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 18513365 by Matthew Pickering at 2026-03-21T04:43:26-04:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 4636d906 by mangoiv at 2026-03-21T04:44:10-04:00 ci: remove obsolete fallback for old debian and ubuntu versions - - - - - 2e3a2805 by mangoiv at 2026-03-21T04:44:10-04:00 ci: drop ubuntu 18 and 20 Ubuntu 18 EOL: May 2023 Ubuntu 20 EOL: May 2025 We should probably not make another major release supporting these platforms. Also updates the generator script. Resolves #25876 - - - - - e2ceef42 by Cheng Shao at 2026-03-21T11:26:29-04:00 rts: fix -Wcompare-distinct-pointer-types errors This commit fixes `-Wcompare-distinct-pointer-types` errors in the RTS which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. - - - - - a4d44ba6 by Cheng Shao at 2026-03-21T11:26:29-04:00 ghc-internal: fix unused imports This commit fixes unused imports in `ghc-internal` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - f343fd14 by Cheng Shao at 2026-03-21T11:26:29-04:00 compiler: fix unused imports in GHC.Tc.Types.Origin This commit fixes unused imports in `GHC.Tc.Types.Origin` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #27059. - - - - - 3958513a by Cheng Shao at 2026-03-21T11:26:30-04:00 hadrian: fix missing +werror in validate flavour This patch fixes missing `+werror` in validate flavour, which was an oversight in bb3a2ba1eefadf0b2ef4f39b31337a23eec67f29. Fixes #27066. - - - - - 55fb9b87 by Cheng Shao at 2026-03-21T11:26:30-04:00 ci: bump CACHE_REV and add the missing reminder This patch bumps `CACHE_REV` to address recent `[Cabal-7159]` CI errors due to stale cabal cache on some runners, and also adds a reminder to remind future maintainers. Fixes #27075. - - - - - 31 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/flake.lock - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Tc/Types/Origin.hs - docs/users_guide/utils.py - hadrian/cabal.project - hadrian/src/Settings/Flavours/Validate.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - rts/Interpreter.c - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6888f3780d98629ae831830a475fc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6888f3780d98629ae831830a475fc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ChickenProp/fix-werror-glibc-2.43
by Phil Hazelden (＠ChickenProp) 21 Mar '26

21 Mar '26

Phil Hazelden pushed new branch wip/ChickenProp/fix-werror-glibc-2.43 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ChickenProp/fix-werror-glibc-… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T11955
by Simon Jakobi (＠sjakobi2) 21 Mar '26

21 Mar '26

Simon Jakobi pushed new branch wip/sjakobi/T11955 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T11955 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: ci: remove obsolete fallback for old debian and ubuntu versions
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4636d906 by mangoiv at 2026-03-21T04:44:10-04:00 ci: remove obsolete fallback for old debian and ubuntu versions - - - - - 2e3a2805 by mangoiv at 2026-03-21T04:44:10-04:00 ci: drop ubuntu 18 and 20 Ubuntu 18 EOL: May 2023 Ubuntu 20 EOL: May 2025 We should probably not make another major release supporting these platforms. Also updates the generator script. Resolves #25876 - - - - - 7 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/flake.lock - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - docs/users_guide/utils.py Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1212,10 +1212,6 @@ ghcup-metadata-nightly: artifacts: false - job: nightly-x86_64-linux-ubuntu22_04-validate artifacts: false - - job: nightly-x86_64-linux-ubuntu20_04-validate - artifacts: false - - job: nightly-x86_64-linux-ubuntu18_04-validate - artifacts: false - job: nightly-x86_64-linux-rocky8-validate artifacts: false - job: nightly-x86_64-darwin-validate ===================================== .gitlab/generate-ci/flake.lock ===================================== @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1710146030, - "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -20,12 +20,10 @@ }, "nixpkgs": { "locked": { - "lastModified": 1724334015, - "narHash": "sha256-5sfvc0MswIRNdRWioUhG58rGKGn2o90Ck6l6ClpwQqA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6d204f819efff3d552a88d0a44b5aaaee172b784", - "type": "github" + "lastModified": 0, + "narHash": "sha256-M0yS4AafhKxPPmOHGqIV0iKxgNO8bHDWdl1kOwGBwRY=", + "path": "/nix/store/nbylyyw8k98a0an6p6nz0hvk5psygwb8-source", + "type": "path" }, "original": { "id": "nixpkgs", ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -122,8 +122,6 @@ data LinuxDistro | Ubuntu2404LoongArch64 | Ubuntu2404 | Ubuntu2204 - | Ubuntu2004 - | Ubuntu1804 | Alpine312 | Alpine323 | AlpineWasm @@ -326,8 +324,6 @@ distroName Debian13Riscv = "deb13-riscv" distroName Debian12Wine = "deb12-wine" distroName Fedora43 = "fedora43" distroName Ubuntu2404LoongArch64 = "ubuntu24_04-loongarch" -distroName Ubuntu1804 = "ubuntu18_04" -distroName Ubuntu2004 = "ubuntu20_04" distroName Ubuntu2204 = "ubuntu22_04" distroName Ubuntu2404 = "ubuntu24_04" distroName Alpine312 = "alpine3_12" @@ -1193,9 +1189,7 @@ debian_i386 = ubuntu_x86 :: [JobGroup Job] ubuntu_x86 = - [ disableValidate (standardBuilds Amd64 (Linux Ubuntu1804)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2004)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) + [ disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) , disableValidate (standardBuilds Amd64 (Linux Ubuntu2404)) ] ===================================== .gitlab/jobs.yaml ===================================== @@ -3385,132 +3385,6 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-ubuntu18_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate", - "XZ_OPT": "-9" - } - }, - "nightly-x86_64-linux-ubuntu20_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate", - "XZ_OPT": "-9" - } - }, "nightly-x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -5192,134 +5066,6 @@ "XZ_OPT": "-9" } }, - "release-x86_64-linux-ubuntu18_04-release": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "1 year", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-release", - "BUILD_FLAVOUR": "release", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "IGNORE_PERF_FAILURES": "all", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-release", - "XZ_OPT": "-9" - } - }, - "release-x86_64-linux-ubuntu20_04-release": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "1 year", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-release", - "BUILD_FLAVOUR": "release", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "IGNORE_PERF_FAILURES": "all", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-release", - "XZ_OPT": "-9" - } - }, "release-x86_64-linux-ubuntu22_04-release": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -7472,130 +7218,6 @@ "TEST_ENV": "x86_64-linux-rocky8-validate" } }, - "x86_64-linux-ubuntu18_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu18_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate" - } - }, - "x86_64-linux-ubuntu20_04-validate": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_…", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu20_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate" - } - }, "x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -21,8 +21,6 @@ def job_triple(job_name): 'release-x86_64-linux-rocky8-release': 'x86_64-rocky8-linux', 'release-x86_64-linux-ubuntu24_04-release': 'x86_64-ubuntu24_04-linux', 'release-x86_64-linux-ubuntu22_04-release': 'x86_64-ubuntu22_04-linux', - 'release-x86_64-linux-ubuntu20_04-release': 'x86_64-ubuntu20_04-linux', - 'release-x86_64-linux-ubuntu18_04-release': 'x86_64-ubuntu18_04-linux', 'release-x86_64-linux-fedora43-release': 'x86_64-fedora43-linux', 'release-x86_64-linux-fedora43-release+debug_info': 'x86_64-fedora43-linux-dwarf', 'release-x86_64-linux-deb13-release': 'x86_64-deb13-linux', ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -195,8 +195,6 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform)) # Here are all the bindists we can distribute - ubuntu1804 = mk(ubuntu("18_04")) - ubuntu2004 = mk(ubuntu("20_04")) ubuntu2204 = mk(ubuntu("22_04")) ubuntu2404 = mk(ubuntu("24_04")) rocky8 = mk(rocky("8")) @@ -227,15 +225,13 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): , "( >= 12 && < 13 )": deb12 , ">= 13": deb13 , "unknown_versioning": deb11 } - , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2004 - , "( >= 18 && < 19 )": ubuntu1804 - , "( >= 19 && < 21 )": ubuntu2004 - , "( >= 21 && < 24 )": ubuntu2204 + , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2204 + , "( < 24 )": ubuntu2204 , "( >= 24 )": ubuntu2404 } - , "Linux_Mint" : { "< 20": ubuntu1804 - , ">= 20": ubuntu2004 - , "unknown_versioning": ubuntu2004 } + , "Linux_Mint" : { "< 24": ubuntu2204 + , ">= 24": ubuntu2404 + , "unknown_versioning": ubuntu2204 } , "Linux_CentOS" : { "( >= 8 && < 9 )" : rocky8 , "unknown_versioning" : rocky8 } , "Linux_Fedora" : { ">= 43": fedora43 ===================================== docs/users_guide/utils.py ===================================== @@ -1,11 +1,6 @@ from docutils import nodes -# N.B. `packaging` is not available in Ubuntu 18.04 or Debian 9 -# See #23818. -try: - from packaging.version import parse as parse_version -except ImportError as e: - from distutils.version import LooseVersion as parse_version +from packaging.version import parse as parse_version # Taken from Docutils source inside the ListTable class. We must bypass # using the class itself, but this function comes in handy. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1851336595243259a37eaac75aba17… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1851336595243259a37eaac75aba17… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add support for custom external interpreter commands
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

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

1 0