- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/haanss/depdir] sort fingerprints before combining them to make getDirHash more robust
by Hassan Al-Awwadi (＠hassan.awwadi) 07 Jul '25

07 Jul '25

Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: 48faafcd by Hassan Al-Awwadi at 2025-07-07T11:33:23+02:00 sort fingerprints before combining them to make getDirHash more robust - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -71,6 +71,7 @@ import qualified Data.Map as M import GHC.Driver.Env import GHC.Driver.Config.Finder import qualified Data.Set as Set +import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified System.Directory as SD import qualified System.OsPath as OsPath @@ -161,8 +162,9 @@ getDirHash dir = do contents <- SD.listDirectory dir -- The documentation of Fingerprints describes this as an easy naive implementation -- I wonder if we should do something more sophisticated here? - let hashes = fingerprintString <$> contents - let hash = fingerprintFingerprints hashes + let hashes = fingerprintString <$> contents + let s_hashes = L.sort hashes + let hash = fingerprintFingerprints s_hashes return hash -- ----------------------------------------------------------------------------- ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1780,8 +1780,8 @@ module Language.Haskell.TH.Syntax where type VarStrictType :: * type VarStrictType = VarBangType addCorePlugin :: GHC.Internal.Base.String -> Q () - addDependentFile :: GHC.Internal.IO.FilePath -> Q () addDependentDirectory :: GHC.Internal.IO.FilePath -> Q () + addDependentFile :: GHC.Internal.IO.FilePath -> Q () addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q () addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q () addForeignSource :: ForeignSrcLang -> GHC.Internal.Base.String -> Q () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48faafcd586daa8bcd606ea4edd4ab0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48faafcd586daa8bcd606ea4edd4ab0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26176
by Simon Peyton Jones (＠simonpj) 07 Jul '25

07 Jul '25

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

1 0

[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 07 Jul '25

07 Jul '25

Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC Commits: c6c8f991 by Teo Camarasu at 2025-07-07T10:04:44+01:00 Implement user-defined allocation limit handlers Allocation Limits allow killing a thread if they allocate more than a user-specified limit. We extend this feature to allow more versatile behaviour. - We allow not killing the thread if the limit is exceeded. - We allow setting a custom handler to be called when the limit is exceeded. User-specified allocation limit handlers run in a fresh thread and are passed the ThreadId of the thread that exceeded its limit. We introduce utility functions for getting and setting the allocation limits of other threads, so that users can reset the limit of a thread from a handler. Both of these are somewhat coarse-grained as we are unaware of the allocations in the current nursery chunk. We provide several examples of usages in testsuite/tests/rts/T22859.hs Resolves #22859 - - - - - 28 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/System/Mem/Experimental.hs - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsStartup.c - rts/RtsSymbols.c - rts/Schedule.c - rts/external-symbols.list.in - rts/include/rts/storage/GC.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/T22859.stderr - testsuite/tests/rts/all.T Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp effect = ReadWriteEffect out_of_line = True +primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp + Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the another thread to the given value. + This doesn't take allocations into the current nursery chunk into account. + Therefore it is only accurate if the other thread is not currently running. } + with + effect = ReadWriteEffect + out_of_line = True + primtype StackSnapshot# { Haskell representation of a @StgStack*@ that was created (cloned) with a function in "GHC.Stack.CloneStack". Please check the ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1775,6 +1775,7 @@ emitPrimOp cfg primop = TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal SetThreadAllocationCounter -> alwaysExternal + SetOtherThreadAllocationCounter -> alwaysExternal KeepAliveOp -> alwaysExternal where ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n SetThreadAllocationCounter -> unhandledPrimop op + SetOtherThreadAllocationCounter -> unhandledPrimop op ------------------------------- Vector ----------------------------------------- -- For now, vectors are unsupported on the JS backend. Simply put, they do not ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -38,6 +38,7 @@ library GHC.RTS.Flags.Experimental GHC.Stats.Experimental Prelude.Experimental + System.Mem.Experimental if arch(wasm32) exposed-modules: GHC.Wasm.Prim other-extensions: ===================================== libraries/ghc-experimental/src/System/Mem/Experimental.hs ===================================== @@ -0,0 +1,10 @@ +module System.Mem.Experimental + ( setGlobalAllocationLimitHandler + , AllocationLimitKillBehaviour(..) + , getAllocationCounterFor + , setAllocationCounterFor + , enableAllocationLimitFor + , disableAllocationLimitFor + ) + where +import GHC.Internal.AllocationLimitHandler ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -122,6 +122,7 @@ Library rts == 1.0.* exposed-modules: + GHC.Internal.AllocationLimitHandler GHC.Internal.ClosureTypes GHC.Internal.Control.Arrow GHC.Internal.Control.Category ===================================== libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs ===================================== @@ -0,0 +1,117 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# OPTIONS_HADDOCK not-home #-} +module GHC.Internal.AllocationLimitHandler + ( runAllocationLimitHandler + , setGlobalAllocationLimitHandler + , AllocationLimitKillBehaviour(..) + , getAllocationCounterFor + , setAllocationCounterFor + , enableAllocationLimitFor + , disableAllocationLimitFor + ) + where +import GHC.Internal.Base +import GHC.Internal.Conc.Sync (ThreadId(..)) +import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef) +import GHC.Internal.Foreign.C.Types +import GHC.Internal.IO (unsafePerformIO) +import GHC.Internal.Int (Int64(..)) + + +{-# NOINLINE allocationLimitHandler #-} +allocationLimitHandler :: IORef (ThreadId -> IO ()) +allocationLimitHandler = unsafePerformIO (newIORef defaultHandler) + +defaultHandler :: ThreadId -> IO () +defaultHandler _ = pure () + +foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO () + +runAllocationLimitHandler :: ThreadId# -> IO () +runAllocationLimitHandler tid = do + hook <- getAllocationLimitHandler + hook $ ThreadId tid + +getAllocationLimitHandler :: IO (ThreadId -> IO ()) +getAllocationLimitHandler = readIORef allocationLimitHandler + +data AllocationLimitKillBehaviour = + KillOnAllocationLimit + -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the + -- allocation limit is exceeded. + | DontKillOnAllocationLimit + -- ^ Do not throw an exception when the allocation limit is exceeded. + +-- | Define the behaviour for handling allocation limits. +-- The default behaviour is to throw an @AllocationLimitExceeded@ async exception to the thread. +-- This can be overriden using @AllocationLimitKillBehaviour@. +-- +-- We can set a user-specified handler, which can be run in addition to +-- or in place of the exception. +-- This allows for instance logging on the allocation limit being exceeded, +-- or dynamically determining whether to terminate the thread. +-- The handler is not guaranteed to run before the thread is terminated or restarted. +-- +-- Note: that if you don't terminate the thread, then the allocation limit gets +-- removed. +-- If you wish to keep the allocation limit you will have to reset it using +-- @setAllocationCounter@ and @enableAllocationLimit@. +setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO () +setGlobalAllocationLimitHandler killBehaviour mHandler = do + shouldRunHandler <- case mHandler of + Just hook -> do + writeIORef allocationLimitHandler hook + pure 1 + Nothing -> do + writeIORef allocationLimitHandler defaultHandler + pure 0 + let shouldKill = + case killBehaviour of + KillOnAllocationLimit -> 1 + DontKillOnAllocationLimit -> 0 + setAllocLimitKill shouldKill shouldRunHandler + +-- | Retrieves the allocation counter for the another thread. +foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter# + :: ThreadId# + -> State# RealWorld + -> (# State# RealWorld, Int64# #) + +-- | Get the allocation counter for a different thread. +-- +-- Note: this doesn't take the current nursery chunk into account. +-- If the thread is running then it may underestimate allocations by the size of a nursery thread. +getAllocationCounterFor :: ThreadId -> IO Int64 +getAllocationCounterFor (ThreadId t#) = IO $ \s -> + case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #) + +-- | Set the allocation counter for a different thread. +-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread. +-- You may wish to do this during a user-specified allocation limit handler. +-- +-- Note: this doesn't take the current nursery chunk into account. +-- If the thread is running then it may overestimate allocations by the size of a nursery thread, +-- and trigger the limit sooner than expected. +setAllocationCounterFor :: Int64 -> ThreadId -> IO () +setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s -> + case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #) + + +-- | Enable allocation limit processing the thread @t@. +enableAllocationLimitFor :: ThreadId -> IO () +enableAllocationLimitFor (ThreadId t) = do + rts_enableThreadAllocationLimit t + +-- | Disable allocation limit processing the thread @t@. +disableAllocationLimitFor :: ThreadId -> IO () +disableAllocationLimitFor (ThreadId t) = do + rts_disableThreadAllocationLimit t + +foreign import ccall unsafe "rts_enableThreadAllocationLimit" + rts_enableThreadAllocationLimit :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableThreadAllocationLimit" + rts_disableThreadAllocationLimit :: ThreadId# -> IO () ===================================== rts/Prelude.h ===================================== @@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure); PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure); +PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure); PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info); PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info); @@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info); #if defined(mingw32_HOST_OS) #define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure) #endif +#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure) #define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure) #define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure) ===================================== rts/PrimOps.cmm ===================================== @@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh () return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset)); } +stg_getOtherThreadAllocationCounterzh ( gcptr t ) +{ + return (StgTSO_alloc_limit(t)); +} + stg_setThreadAllocationCounterzh ( I64 counter ) { // Allocation in the current block will be subtracted by @@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter ) return (); } +stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t ) +{ + StgTSO_alloc_limit(t) = counter; + return (); +} + #define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \ w_ info_ptr, \ ===================================== rts/RtsStartup.c ===================================== @@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void) * GHC.Core.Make.mkExceptionId. */ getStablePtr((StgPtr)absentSumFieldError_closure); + getStablePtr((StgPtr)runAllocationLimitHandler_closure); } void ===================================== rts/RtsSymbols.c ===================================== @@ -748,6 +748,7 @@ extern char **environ; SymI_HasProto(rts_enableThreadAllocationLimit) \ SymI_HasProto(rts_disableThreadAllocationLimit) \ SymI_HasProto(rts_setMainThread) \ + SymI_HasProto(setAllocLimitKill) \ SymI_HasProto(setProgArgv) \ SymI_HasProto(startupHaskell) \ SymI_HasProto(shutdownHaskell) \ @@ -916,7 +917,9 @@ extern char **environ; SymI_HasDataProto(stg_traceMarkerzh) \ SymI_HasDataProto(stg_traceBinaryEventzh) \ SymI_HasDataProto(stg_getThreadAllocationCounterzh) \ + SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \ SymI_HasDataProto(stg_setThreadAllocationCounterzh) \ + SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \ SymI_HasProto(getMonotonicNSec) \ SymI_HasProto(lockFile) \ SymI_HasProto(unlockFile) \ ===================================== rts/Schedule.c ===================================== @@ -41,6 +41,7 @@ #include "Threads.h" #include "Timer.h" #include "ThreadPaused.h" +#include "ThreadLabels.h" #include "Messages.h" #include "StablePtr.h" #include "StableName.h" @@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES; */ StgWord sched_state = SCHED_RUNNING; + +bool allocLimitKill = true; +bool allocLimitRunHook = false; + /* * This mutex protects most of the global scheduler data in * the THREADED_RTS runtime. @@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t) } } - // - // If the current thread's allocation limit has run out, send it - // the AllocationLimitExceeded exception. + // Handle the current thread's allocation limit running out, if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) { - // Use a throwToSelf rather than a throwToSingleThreaded, because - // it correctly handles the case where the thread is currently - // inside mask. Also the thread might be blocked (e.g. on an - // MVar), and throwToSingleThreaded doesn't unblock it - // correctly in that case. - throwToSelf(cap, t, allocationLimitExceeded_closure); - ASSIGN_Int64((W_*)&(t->alloc_limit), - (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE); + if(allocLimitKill) { + // Throw the AllocationLimitExceeded exception. + // Use a throwToSelf rather than a throwToSingleThreaded, because + // it correctly handles the case where the thread is currently + // inside mask. Also the thread might be blocked (e.g. on an + // MVar), and throwToSingleThreaded doesn't unblock it + // correctly in that case. + throwToSelf(cap, t, allocationLimitExceeded_closure); + ASSIGN_Int64((W_*)&(t->alloc_limit), + (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE); + } else { + // If we aren't killing the thread, we must disable the limit + // otherwise we will immediatelly retrigger it. + // User defined handlers should re-enable it if wanted. + t->flags = t->flags & ~TSO_ALLOC_LIMIT; + } + + if(allocLimitRunHook) + { + // Create a thread to run the allocation limit handler. + StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t); + StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c); + setThreadLabel(cap, hookThread, "allocation limit handler thread"); + // Schedule the handler to be run immediatelly. + pushOnRunQueue(cap, hookThread); + } + } /* some statistics gathering in the parallel case */ @@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads) } } } + +void setAllocLimitKill(bool shouldKill, bool shouldHook) +{ + allocLimitKill = shouldKill; + allocLimitRunHook = shouldHook; +} ===================================== rts/external-symbols.list.in ===================================== @@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info ghczminternal_GHCziInternalziTypes_Fzh_con_info ghczminternal_GHCziInternalziTypes_Dzh_con_info ghczminternal_GHCziInternalziTypes_Wzh_con_info +ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure ghczminternal_GHCziInternalziPtr_Ptr_con_info ghczminternal_GHCziInternalziPtr_FunPtr_con_info ghczminternal_GHCziInternalziInt_I8zh_con_info ===================================== rts/include/rts/storage/GC.h ===================================== @@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr); // Used by GC checks in external .cmm code: extern W_ large_alloc_lim; +// Should triggering an allocation limit kill the thread +// and should we run a user-defined hook when it is triggered. +void setAllocLimitKill(bool, bool); + /* ----------------------------------------------------------------------------- Performing Garbage Collection -------------------------------------------------------------------------- */ ===================================== rts/include/rts/storage/TSO.h ===================================== @@ -157,9 +157,10 @@ typedef struct StgTSO_ { /* * The allocation limit for this thread, which is updated as the * thread allocates. If the value drops below zero, and - * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the - * thread, and give the thread a little more space to handle the - * exception before we raise the exception again. + * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd. + * Either we raise an exception in the thread, and give the thread + * a little more space to handle the exception before we raise the + * exception again; or we run a user defined handler. * * This is an integer, because we might update it in a place where * it isn't convenient to raise the exception, so we want it to ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh); RTS_FUN_DECL(stg_traceBinaryEventzh); RTS_FUN_DECL(stg_traceMarkerzh); RTS_FUN_DECL(stg_getThreadAllocationCounterzh); +RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh); RTS_FUN_DECL(stg_setThreadAllocationCounterzh); +RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh); RTS_FUN_DECL(stg_castWord64ToDoublezh); RTS_FUN_DECL(stg_castDoubleToWord64zh); ===================================== testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout ===================================== @@ -13,13 +13,13 @@ Building library 'q' instantiated with for bkpcabal08-0.1.0.0... [2 of 4] Compiling B[sig] ( q/B.hsig, nothing ) [3 of 4] Compiling M ( q/M.hs, nothing ) [A changed] -[4 of 4] Instantiating bkpcabal08-0.1.0.0-CoQJNXLfoYQ4TyvApzFHv-p +[4 of 4] Instantiating bkpcabal08-0.1.0.0-LjROTJ30vjpHLvYNUnY1dD-p Preprocessing library 'q' for bkpcabal08-0.1.0.0... Building library 'q' instantiated with - A = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:A - B = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:B + A = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:A + B = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:B for bkpcabal08-0.1.0.0... -[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/A.o ) [Prelude package changed] -[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/B.o ) [Prelude package changed] +[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/A.o ) [Prelude package changed] +[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/B.o ) [Prelude package changed] Preprocessing library 'r' for bkpcabal08-0.1.0.0... Building library 'r' for bkpcabal08-0.1.0.0... ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -4607,6 +4607,7 @@ module GHC.Base where sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a] setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -6693,6 +6694,7 @@ module GHC.Exts where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -4607,6 +4607,7 @@ module GHC.Base where sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a] setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -6665,6 +6666,7 @@ module GHC.Exts where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -4610,6 +4610,7 @@ module GHC.Base where sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a] setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -6836,6 +6837,7 @@ module GHC.Exts where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -4607,6 +4607,7 @@ module GHC.Base where sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a] setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -6693,6 +6694,7 @@ module GHC.Exts where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -5873,6 +5873,7 @@ module GHC.PrimOps where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -10916,6 +10917,16 @@ module Prelude.Experimental where data Unit# = ... getSolo :: forall a. Solo a -> a +module System.Mem.Experimental where + -- Safety: None + type AllocationLimitKillBehaviour :: * + data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit + disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64 + setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO () + -- Instances: instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -5876,6 +5876,7 @@ module GHC.PrimOps where seq# :: forall a s. a -> State# s -> (# State# s, a #) setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shiftL# :: Word# -> Int# -> Word# shiftRL# :: Word# -> Int# -> Word# @@ -10919,6 +10920,16 @@ module Prelude.Experimental where data Unit# = ... getSolo :: forall a. Solo a -> a +module System.Mem.Experimental where + -- Safety: None + type AllocationLimitKillBehaviour :: * + data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit + disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64 + setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO () + setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO () + -- Instances: instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/interface-stability/ghc-prim-exports.stdout ===================================== @@ -2505,6 +2505,7 @@ module GHC.Prim where seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d @@ -3489,6 +3490,7 @@ module GHC.PrimopWrappers where retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #) setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s + setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s ===================================== testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 ===================================== @@ -2505,6 +2505,7 @@ module GHC.Prim where seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d + setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d @@ -3492,6 +3493,7 @@ module GHC.PrimopWrappers where retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #) setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s + setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -0,0 +1,72 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +import Control.Exception +import Control.Exception.Backtrace +import Control.Concurrent +import Control.Concurrent.MVar +import System.Mem +import System.Mem.Experimental +import GHC.IO (IO (..)) +import GHC.Exts +import System.IO + +-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress +worker :: IO () +worker = loop [] 2 + where + loop !m !n + | n > 30 = hPutStrLn stderr . show $ length m + | otherwise = do + let x = show n + hPutStrLn stderr x + -- just to bulk out the allocations + IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #)) + yield + loop (x:m) (n + 1) + +main :: IO () +main = do + hSetBuffering stderr LineBuffering -- necessary for Windows, otherwise our output gets garbled + done <- newMVar () -- we use this lock to wait for the worker to finish + started <- newEmptyMVar + let runWorker = do + forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do + hPutStrLn stderr "worker starting" + putMVar started () + setAllocationCounter 1_000_000 + enableAllocationLimit + worker + hPutStrLn stderr "worker done" + takeMVar started + readMVar done + hFlush stderr + threadDelay 1000 + -- default behaviour: + -- kill it after the limit is exceeded + hPutStrLn stderr "default behaviour" + runWorker + hPutStrLn stderr "just log once on the hook being triggered" + setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1") + runWorker + hPutStrLn stderr "just log on the hook being triggered" + setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do + hPutStrLn stderr "allocation limit triggered 2" + -- re-enable the hook + setAllocationCounterFor 1_000_000 tid + enableAllocationLimitFor tid + runWorker + hPutStrLn stderr "kill from the hook" + setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded + runWorker + -- not super helpful, but let's test it anyway + hPutStrLn stderr "do nothing" + setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing + runWorker + -- this is possible to handle using an exception handler instead. + hPutStrLn stderr "kill and log" + setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3") + runWorker + threadDelay 1000 + hPutStrLn stderr "done" ===================================== testsuite/tests/rts/T22859.stderr ===================================== @@ -0,0 +1,140 @@ +default behaviour +worker starting +2 +3 +worker died +T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException: + +allocation limit exceeded +just log once on the hook being triggered +worker starting +2 +3 +allocation limit triggered 1 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +29 +worker done +just log on the hook being triggered +worker starting +2 +3 +allocation limit triggered 2 +4 +5 +allocation limit triggered 2 +6 +7 +allocation limit triggered 2 +8 +9 +allocation limit triggered 2 +10 +11 +allocation limit triggered 2 +12 +13 +allocation limit triggered 2 +14 +15 +allocation limit triggered 2 +16 +17 +allocation limit triggered 2 +18 +19 +allocation limit triggered 2 +20 +21 +allocation limit triggered 2 +22 +23 +allocation limit triggered 2 +24 +25 +allocation limit triggered 2 +26 +27 +allocation limit triggered 2 +28 +29 +allocation limit triggered 2 +30 +29 +worker done +kill from the hook +worker starting +2 +3 +worker died +T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException: + +allocation limit exceeded +do nothing +worker starting +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +29 +worker done +kill and log +worker starting +2 +3 +allocation limit triggered 3 +worker died +T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException: + +allocation limit exceeded +done ===================================== testsuite/tests/rts/all.T ===================================== @@ -643,3 +643,8 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru test('T25560', [req_c_rts, ignore_stderr], compile_and_run, ['']) test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main']) +test('T22859', + [js_skip, + # Allocation behaviour differs with the wasm backend so we get different output + when(arch('wasm32'), skip)], + compile_and_run, ['-with-rtsopts -A8K']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6c8f991a35c9161672947fdc5d182f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6c8f991a35c9161672947fdc5d182f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] Remove -ddump-json (fixes #24113)
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 49aaf5ad by Simon Hengel at 2025-07-07T15:52:56+07:00 Remove -ddump-json (fixes #24113) - - - - - 11 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -526,7 +526,6 @@ data DumpFlag | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug - | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1657,9 +1657,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_dep_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json) - "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -92,7 +92,6 @@ import GHC.Utils.Panic import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -357,7 +356,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] defaultLogJsonAction :: LogJsonAction defaultLogJsonAction logflags msg_class jsdoc = case msg_class of @@ -374,32 +372,6 @@ defaultLogJsonAction logflags msg_class jsdoc = putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout msg = renderJSON jsdoc --- See Note [JSON Error Messages] --- this is to be removed -jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogActionWithHandle out logflags msg_class srcSpan msg - = - defaultLogActionHPutStrDoc logflags True out - (withPprStyle PprCode (doc $$ text "")) - where - str = renderWithContext (log_default_user_context logflags) msg - doc = renderJSON $ - JSObject [ ( "span", spanToDumpJSON srcSpan ) - , ( "doc" , JSString str ) - , ( "messageClass", json msg_class ) - ] - spanToDumpJSON :: SrcSpan -> JsonDoc - spanToDumpJSON s = case s of - (RealSrcSpan rss _) -> JSObject [ ("file", json file) - , ("startLine", json $ srcSpanStartLine rss) - , ("startCol", json $ srcSpanStartCol rss) - , ("endLine", json $ srcSpanEndLine rss) - , ("endCol", json $ srcSpanEndCol rss) - ] - where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -411,8 +383,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg - | otherwise = case msg_class of + = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) MCInteractive -> putStrSDoc msg @@ -453,28 +424,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- calls to this log-action can output all on the same line = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d --- --- Note [JSON Error Messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. --- --- The recent work here replaces the purpose of flag -ddump-json with --- -fdiagnostics-as-json. For temporary backwards compatibility while --- -ddump-json is being deprecated, `jsonLogAction` has been added in, but --- it should be removed along with -ddump-json. Similarly, the guard in --- `defaultLogAction` should be removed. This cleanup is tracked in #24113. - -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction defaultDumpAction dumps log_action logflags sty flag title _fmt doc = ===================================== docs/users_guide/debugging.rst ===================================== @@ -55,13 +55,6 @@ Dumping out compiler intermediate structures ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the output of one way with the output of another. -.. ghc-flag:: -ddump-json - :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead - :type: dynamic - - This flag was previously used to generated JSON formatted GHC diagnostics, - but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`. - .. ghc-flag:: -dshow-passes :shortdesc: Print out each pass name as it happens :type: dynamic ===================================== ghc/GHCi/UI.hs ===================================== @@ -495,8 +495,6 @@ interactiveUI config srcs maybe_exprs = do installInteractiveHomeUnits - -- Update the LogAction. Ensure we don't override the user's log action lest - -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] pushLogHookM (ghciLogAction lastErrLocationsRef) ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1,2 @@ +{"version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"message":["parse error on input \u2018f\u2019"],"hints":[]} *** Exception: ExitFailure 1 ===================================== testsuite/tests/driver/T16167.stdout deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"} ===================================== testsuite/tests/driver/all.T ===================================== @@ -274,12 +274,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef']) test('T12955', normal, makefile_test, []) test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, []) -test('json_dump', normal, compile_fail, ['-ddump-json']) test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial']) -test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version']) +test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version']) test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command, - ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) + ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs']) test('T13604', [], makefile_test, []) test('T13604a', [ js_broken(22261) # require HPC support ===================================== testsuite/tests/driver/json2.stderr ===================================== @@ -1,2 +1,4 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"} +TYPE SIGNATURES + foo :: forall a. a -> a +Dependent modules: [] +Dependent packages: [(normal, base-4.21.0.0)] ===================================== testsuite/tests/driver/json_dump.hs deleted ===================================== @@ -1,6 +0,0 @@ -module Foo where - -import Data.List - -id1 :: a -> a -id1 = 5 ===================================== testsuite/tests/driver/json_dump.stderr deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49aaf5ad6781e91e717d07c95118dda… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49aaf5ad6781e91e717d07c95118dda… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] Remove -dddump-json (fixes #24113)
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 3a672706 by Simon Hengel at 2025-07-07T15:49:22+07:00 Remove -dddump-json (fixes #24113) - - - - - 11 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -526,7 +526,6 @@ data DumpFlag | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug - | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1657,9 +1657,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_dep_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json) - "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -92,7 +92,6 @@ import GHC.Utils.Panic import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -357,7 +356,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] defaultLogJsonAction :: LogJsonAction defaultLogJsonAction logflags msg_class jsdoc = case msg_class of @@ -374,32 +372,6 @@ defaultLogJsonAction logflags msg_class jsdoc = putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout msg = renderJSON jsdoc --- See Note [JSON Error Messages] --- this is to be removed -jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogActionWithHandle out logflags msg_class srcSpan msg - = - defaultLogActionHPutStrDoc logflags True out - (withPprStyle PprCode (doc $$ text "")) - where - str = renderWithContext (log_default_user_context logflags) msg - doc = renderJSON $ - JSObject [ ( "span", spanToDumpJSON srcSpan ) - , ( "doc" , JSString str ) - , ( "messageClass", json msg_class ) - ] - spanToDumpJSON :: SrcSpan -> JsonDoc - spanToDumpJSON s = case s of - (RealSrcSpan rss _) -> JSObject [ ("file", json file) - , ("startLine", json $ srcSpanStartLine rss) - , ("startCol", json $ srcSpanStartCol rss) - , ("endLine", json $ srcSpanEndLine rss) - , ("endCol", json $ srcSpanEndCol rss) - ] - where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -411,8 +383,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg - | otherwise = case msg_class of + = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) MCInteractive -> putStrSDoc msg @@ -453,28 +424,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- calls to this log-action can output all on the same line = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d --- --- Note [JSON Error Messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. --- --- The recent work here replaces the purpose of flag -ddump-json with --- -fdiagnostics-as-json. For temporary backwards compatibility while --- -ddump-json is being deprecated, `jsonLogAction` has been added in, but --- it should be removed along with -ddump-json. Similarly, the guard in --- `defaultLogAction` should be removed. This cleanup is tracked in #24113. - -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction defaultDumpAction dumps log_action logflags sty flag title _fmt doc = ===================================== docs/users_guide/debugging.rst ===================================== @@ -55,13 +55,6 @@ Dumping out compiler intermediate structures ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the output of one way with the output of another. -.. ghc-flag:: -ddump-json - :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead - :type: dynamic - - This flag was previously used to generated JSON formatted GHC diagnostics, - but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`. - .. ghc-flag:: -dshow-passes :shortdesc: Print out each pass name as it happens :type: dynamic ===================================== ghc/GHCi/UI.hs ===================================== @@ -495,8 +495,6 @@ interactiveUI config srcs maybe_exprs = do installInteractiveHomeUnits - -- Update the LogAction. Ensure we don't override the user's log action lest - -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] pushLogHookM (ghciLogAction lastErrLocationsRef) ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1,2 @@ +{"version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"message":["parse error on input \u2018f\u2019"],"hints":[]} *** Exception: ExitFailure 1 ===================================== testsuite/tests/driver/T16167.stdout deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"} ===================================== testsuite/tests/driver/all.T ===================================== @@ -274,12 +274,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef']) test('T12955', normal, makefile_test, []) test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, []) -test('json_dump', normal, compile_fail, ['-ddump-json']) test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial']) -test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version']) +test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version']) test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command, - ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) + ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs']) test('T13604', [], makefile_test, []) test('T13604a', [ js_broken(22261) # require HPC support ===================================== testsuite/tests/driver/json2.stderr ===================================== @@ -1,2 +1,4 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"} +TYPE SIGNATURES + foo :: forall a. a -> a +Dependent modules: [] +Dependent packages: [(normal, base-4.21.0.0)] ===================================== testsuite/tests/driver/json_dump.hs deleted ===================================== @@ -1,6 +0,0 @@ -module Foo where - -import Data.List - -id1 :: a -> a -id1 = 5 ===================================== testsuite/tests/driver/json_dump.stderr deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a672706f4eba45846495a1e3c2c55f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a672706f4eba45846495a1e3c2c55f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] Remove -dddump-json
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: a77a3619 by Simon Hengel at 2025-07-07T15:47:56+07:00 Remove -dddump-json - - - - - 11 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -526,7 +526,6 @@ data DumpFlag | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug - | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1657,9 +1657,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_dep_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json) - "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -92,7 +92,6 @@ import GHC.Utils.Panic import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -357,7 +356,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] defaultLogJsonAction :: LogJsonAction defaultLogJsonAction logflags msg_class jsdoc = case msg_class of @@ -374,32 +372,6 @@ defaultLogJsonAction logflags msg_class jsdoc = putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout msg = renderJSON jsdoc --- See Note [JSON Error Messages] --- this is to be removed -jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogActionWithHandle out logflags msg_class srcSpan msg - = - defaultLogActionHPutStrDoc logflags True out - (withPprStyle PprCode (doc $$ text "")) - where - str = renderWithContext (log_default_user_context logflags) msg - doc = renderJSON $ - JSObject [ ( "span", spanToDumpJSON srcSpan ) - , ( "doc" , JSString str ) - , ( "messageClass", json msg_class ) - ] - spanToDumpJSON :: SrcSpan -> JsonDoc - spanToDumpJSON s = case s of - (RealSrcSpan rss _) -> JSObject [ ("file", json file) - , ("startLine", json $ srcSpanStartLine rss) - , ("startCol", json $ srcSpanStartCol rss) - , ("endLine", json $ srcSpanEndLine rss) - , ("endCol", json $ srcSpanEndCol rss) - ] - where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -411,8 +383,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg - | otherwise = case msg_class of + = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) MCInteractive -> putStrSDoc msg @@ -453,28 +424,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- calls to this log-action can output all on the same line = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d --- --- Note [JSON Error Messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. --- --- The recent work here replaces the purpose of flag -ddump-json with --- -fdiagnostics-as-json. For temporary backwards compatibility while --- -ddump-json is being deprecated, `jsonLogAction` has been added in, but --- it should be removed along with -ddump-json. Similarly, the guard in --- `defaultLogAction` should be removed. This cleanup is tracked in #24113. - -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction defaultDumpAction dumps log_action logflags sty flag title _fmt doc = ===================================== docs/users_guide/debugging.rst ===================================== @@ -55,13 +55,6 @@ Dumping out compiler intermediate structures ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the output of one way with the output of another. -.. ghc-flag:: -ddump-json - :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead - :type: dynamic - - This flag was previously used to generated JSON formatted GHC diagnostics, - but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`. - .. ghc-flag:: -dshow-passes :shortdesc: Print out each pass name as it happens :type: dynamic ===================================== ghc/GHCi/UI.hs ===================================== @@ -495,8 +495,6 @@ interactiveUI config srcs maybe_exprs = do installInteractiveHomeUnits - -- Update the LogAction. Ensure we don't override the user's log action lest - -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] pushLogHookM (ghciLogAction lastErrLocationsRef) ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1,2 @@ +{"version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"message":["parse error on input \u2018f\u2019"],"hints":[]} *** Exception: ExitFailure 1 ===================================== testsuite/tests/driver/T16167.stdout deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"} ===================================== testsuite/tests/driver/all.T ===================================== @@ -274,12 +274,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef']) test('T12955', normal, makefile_test, []) test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, []) -test('json_dump', normal, compile_fail, ['-ddump-json']) test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial']) -test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version']) +test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version']) test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command, - ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) + ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs']) test('T13604', [], makefile_test, []) test('T13604a', [ js_broken(22261) # require HPC support ===================================== testsuite/tests/driver/json2.stderr ===================================== @@ -1,2 +1,4 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"} +TYPE SIGNATURES + foo :: forall a. a -> a +Dependent modules: [] +Dependent packages: [(normal, base-4.21.0.0)] ===================================== testsuite/tests/driver/json_dump.hs deleted ===================================== @@ -1,6 +0,0 @@ -module Foo where - -import Data.List - -id1 :: a -> a -id1 = 5 ===================================== testsuite/tests/driver/json_dump.stderr deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a77a3619c18d12be08aaed29c7d0497… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a77a3619c18d12be08aaed29c7d0497… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] Annotate frame
by Hannes Siebenhandl (＠fendor) 07 Jul '25

07 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 561cb31e by Ben Gamari at 2025-07-03T11:41:56+02:00 Annotate frame - - - - - 32 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Stack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - + libraries/ghc-heap/tests/stack-annotation/Makefile - + libraries/ghc-heap/tests/stack-annotation/all.T - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - rts/ClosureFlags.c - rts/LdvProfile.c - rts/PrimOps.cmm - rts/Printer.c - rts/RetainerProfile.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureTypes.h - rts/include/rts/storage/Closures.h - rts/js/profiling.js - rts/sm/Compact.c - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/561cb31e29e74aea7159b7ea275987a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/561cb31e29e74aea7159b7ea275987a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sol/remove-ddump-json
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

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

1 0

[Git][ghc/ghc][wip/sol/pre-processors-errors] Respect `-fdiagnostics-as-json` for error messages from pre-processors
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

Simon Hengel pushed to branch wip/sol/pre-processors-errors at Glasgow Haskell Compiler / GHC Commits: a8fa2945 by Simon Hengel at 2025-07-07T13:22:14+07:00 Respect `-fdiagnostics-as-json` for error messages from pre-processors (fixes #25480) - - - - - 3 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/SysTools/Process.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -1,18 +1,34 @@ {-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( - printOrThrowDiagnostics + reportError , printMessages + , printOrThrowDiagnostics , mkDriverPsHeaderMessage ) where import GHC.Driver.Errors.Types import GHC.Prelude +import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error -import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) +import GHC.Utils.Outputable import GHC.Utils.Logger +reportError :: Logger -> SrcSpan -> SDoc -> IO () +reportError logger span message = do + printMessages logger NoDiagnosticOpts emptyDiagOpts $ singleMessage MsgEnvelope { + errMsgSpan = span + , errMsgContext = alwaysQualify + , errMsgDiagnostic = DiagnosticMessage { + diagMessage = mkDecorated [message] + , diagReason = ErrorWithoutFlag + , diagHints = [] + } + , errMsgSeverity = SevError + , errMsgReason = ResolvedDiagnosticReason ErrorWithoutFlag + } + printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts msgs = sequence_ [ let style = mkErrStyle name_ppr_ctx ===================================== compiler/GHC/SysTools/Process.hs ===================================== @@ -26,6 +26,8 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.CliOption +import GHC.Driver.Errors (reportError) + import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString @@ -286,8 +288,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg BuildError loc msg -> do - logMsg logger errorDiagnostic (mkSrcSpan loc loc) - $ withPprStyle defaultUserStyle msg + reportError logger (mkSrcSpan loc loc) msg parseBuildMessages :: [String] -> [BuildMessage] parseBuildMessages str = loop str Nothing ===================================== ghc/GHCi/UI.hs ===================================== @@ -52,7 +52,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Driver.Flags -import GHC.Driver.Errors +import GHC.Driver.Errors (printOrThrowDiagnostics) import GHC.Driver.Errors.Types import GHC.Driver.Phases import GHC.Driver.Session as DynFlags View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8fa2945c584d47490f6b37af6c2822… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8fa2945c584d47490f6b37af6c2822… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sol/pre-processors-errors
by Simon Hengel (＠sol) 07 Jul '25

07 Jul '25

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

1 0