Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f8c24b51 by Teo Camarasu at 2026-03-12T01:26:31-04:00 ghc-internal: move bits Weak of finalizer interface to base We move parts of the Weak finalizer interface to `base` only the parts that the RTS needs to know about are kept in `ghc-internal`. This lets us then prune our imports somewhat and get rid of some SOURCE imports. Resolves #26985 - - - - - e1b8e539 by Sylvain Henry at 2026-03-12T01:27:01-04:00 Stg/Unarise: constant-folding during unarisation (#25650) When building an unboxed sum from a literal argument, mkUbxSum previously emitted a runtime cast via `case primop [lit] of var -> ...`. This wrapper prevented GHC from recognising the result as a static StgRhsCon, causing top-level closures to be allocated as thunks instead of being statically allocated. Fix: try to perform the numeric literal cast at compile time using mkLitNumberWrap (wrapping semantics). If successful, return the cast literal directly with an identity wrapper (no case expression). The runtime cast path is kept as fallback for non-literal arguments. Test: codeGen/should_compile/T25650 - - - - - 25ae85a8 by Sylvain Henry at 2026-03-12T01:27:07-04:00 T17912: wait for opener thread to block before killing it (#24739) Instead of a fixed 1000ms delay, poll threadStatus until the opener thread is in BlockedOnForeignCall, ensuring killThread only fires once the thread is provably inside the blocking open() syscall. This prevents the test from accidentally passing on Windows due to scheduling races. - - - - - 62fe65ba by Cheng Shao at 2026-03-12T01:27:07-04:00 template-haskell: fix redundant import in Language.Haskell.TH.Quote This patch fixes a redundant import in `Language.Haskell.TH.Quote` that causes a ghc build failure when bootstrapping from 9.14 with validate flavours. Fixes #27014. - - - - - 6af6ba92 by Brandon Simmons at 2026-03-12T01:27:19-04:00 Add a cumulative gc_sync_elapsed_ns counter to GHC.Internal.Stats This makes it possible to get an accurate view of time spent in sync phase when using prometheus-style sampling. Previously this was only available for the most recent GC. This intentionally leaves GHC.Stats API unchanged since it is marked as deprecated, and API changes there require CLC approval. Fixes #26944 - - - - - 25 changed files: - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/Stg/Unarise.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - − libraries/base/src/GHC/Weak/Finalizehs - libraries/base/src/System/Mem/Weak.hs - libraries/base/tests/IO/T17912.hs - libraries/base/tests/IO/all.T - libraries/ghc-internal/CHANGELOG.md - − libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs-boot - − libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - rts/Stats.c - rts/include/RtsAPI.h - testsuite/tests/codeGen/should_compile/Makefile - + testsuite/tests/codeGen/should_compile/T25650.hs - + testsuite/tests/codeGen/should_compile/T25650.stdout - testsuite/tests/codeGen/should_compile/all.T - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -143,7 +143,7 @@ stg2stg logger extra_vars opts this_mod binds StgUnarise -> do us <- getUniqueSupplyM liftIO (stg_linter False "Pre-unarise" binds) - let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds + let binds' = {-# SCC "StgUnarise" #-} unarise (stgPlatform opts) us (stgPipeline_allowTopLevelConApp opts this_mod) binds liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') liftIO (stg_linter True "Unarise" binds') return binds' ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -413,6 +413,7 @@ import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Casts +import GHC.Platform import Data.List (mapAccumL) -- import GHC.Utils.Trace @@ -441,12 +442,13 @@ import Data.List (mapAccumL) -- (i.e. no unboxed tuples, sums or voids) -- data UnariseEnv = UnariseEnv - { ue_rho :: (VarEnv UnariseVal) + { ue_platform :: !Platform + , ue_rho :: VarEnv UnariseVal , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool } -initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv -initUnariseEnv = UnariseEnv +initUnariseEnv :: Platform -> VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv +initUnariseEnv platform rho is_dll = UnariseEnv platform rho is_dll data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). @@ -479,8 +481,8 @@ lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- -unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] -unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds) +unarise :: Platform -> UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] +unarise platform us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv platform emptyVarEnv is_dll_con_app)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -627,7 +629,7 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + = let (args2, cast_wrapper) = mkUbxSum (ue_platform rho) dc ty_args args1 us in (args2, Just cast_wrapper) | otherwise @@ -848,29 +850,29 @@ mapSumIdBinders alt_bndr args rhs rho0 -- right type. -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] - id_vars = [v | StgVarArg v <- id_arg_exprs] - typed_id_arg_input = assert (equalLength id_vars fld_reps) $ - zip3 id_vars fld_reps uss - - mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep + typed_id_arg_input = assert (equalLength id_arg_exprs fld_reps) $ + zip3 id_arg_exprs fld_reps uss + + -- Process each (arg, target rep, unique supply) to produce + -- (rhs wrapper, typed arg). Handles both literal and variable args. + -- Literal args can arise after constant-folding in mkUbxSum + -- (see Note [Constant-folding during unarisation]). + mkCastArg :: (StgArg, PrimRep, UniqSupply) -> (StgExpr -> StgExpr, StgArg) + mkCastArg (StgLitArg lit, rep, _us) + | Just lit' <- castLiteralArg (ue_platform rho0) rep lit + = (id, StgLitArg lit') + | otherwise = pprPanic "mapSumIdBinders: cannot cast literal" (ppr lit $$ ppr rep) + mkCastArg (StgVarArg v, rep, bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType v) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of - [] -> id - _ -> let (_,ty,uq) = last cst_opts - in mkCastVar uq ty - in (cst_opts,id,out_id) - - cast_inputs = map mkCastInput typed_id_arg_input - (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs - where - cast_arg rhs_in (cast_ops,in_id,out_id) = - let rhs_out = castArgRename cast_ops (StgVarArg in_id) - in (rhs_in . rhs_out, out_id) + [] -> v + _ -> let (_,ty,uq) = last cst_opts in mkCastVar uq ty + in (castArgRename cst_opts (StgVarArg v), StgVarArg out_id) - typed_id_args = map StgVarArg typed_ids + (wrappers, typed_id_args) = unzip $ map mkCastArg typed_id_arg_input + rhs_with_casts = foldr (.) id wrappers if isMultiValBndr alt_bndr then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) @@ -913,14 +915,15 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- mkUbxSum :: HasDebugCallStack - => DataCon -- Sum data con + => Platform -- For compile-time constant-folding + -> DataCon -- Sum data con -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments ,(StgExpr->StgExpr) -- We might need to cast the args first ) -mkUbxSum dc ty_args args0 us +mkUbxSum platform dc ty_args args0 us = let tag_slot :| sum_slots = ubxSumRepType ty_args -- drop tag slot @@ -961,6 +964,11 @@ mkUbxSum dc ty_args args0 us , ubxSumRubbishArg slot) castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg@(StgLitArg lit) + -- See Note [Constant-folding during unarisation] + | slotPrimRep slot_ty /= stgArgRepU arg + , Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit + = Just (StgLitArg lit', us, id) castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRepU arg @@ -1006,6 +1014,101 @@ ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) where vec_rep = primRepToRuntimeRep (VecRep n e) +{- +Note [Constant-folding during unarisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #25650. + +Goal: ensure that top-level bindings whose unboxed-sum fields are literals +become statically allocated closures (i.e. compile-time constants in the +object file) rather than CAFs. + +Background: A top-level RHS is statically allocated when it is a plain +`StgRhsCon`: a data constructor applied to arguments with no surrounding +expression. Any `StgCase` wrapper, even one that is a no-op at runtime, turns +the RHS into a CAF. + +The problem: When `mkUbxSum` builds an unboxed sum whose argument PrimRep does +not match the slot PrimRep, the general `castArg` path emits a runtime conversion +wrapper: + + case arg of x' -> + +For a *variable* argument this is unavoidable, the value is not known at +compile time. For a *literal* argument, however, the conversion can be performed +at compile time, avoiding the `StgCase` wrapper entirely. + +Example +~~~~~~~ +Consider: + + data A = MkA (# Int16# | Int32# #) + foo = MkA (# 10#Int16 | #) + +By the time this gets to the end of the Simplifier pipeline, this still looks +like: + foo = MkA (# 10#Int16 | #) +That is: the worker for the data constructor takes an unboxed sum as its +argument. + +The Unarise pass, which works on STG, decides that + (# 10#Int16 | #) :: (# Int16# | Int32# #) +should be represented as an pair of an integer tag (of type `Int8#`) and a payload +value (of type `Word32#`). But to do that it has to convert `10#Int16` into +`Word32#`, and that conversion is not a no-op. So without constant-folding we +get: + + foo = + \u [] + case int16ToWord16# [10#Int16] of cst_sum_gio { + __DEFAULT -> + case word16ToWord# [cst_sum_gio] of cst_sum_gip { + __DEFAULT -> MkA [1# cst_sum_gip]; + }; + }; + +Note that in the output of the unarise pass, the worker `MkA` takes two +arguments: the tag and the payload of our unboxed sum.. + +However it's a bit silly to generate a CAF here because with some +constant-folding we can easily avoid this thunk and generate a static datacon +instead. That's why the literal clause of `castArg` intercepts `Int16# 10`, +calls `castLiteralArg` to compute `Word32# 10` at compile time, and returns the +identity wrapper. The result is: + + foo = MkA! [1#Word8 10#Word32]; + + +Note that `castLiteralArg` uses `mkLitNumberWrap`, which matches the +semantics of GHC's integer-conversion primops (zero/sign extension to the target +width) — exactly the same transformation the runtime conversion would have +performed. + +-} + +-- | Try to convert a numeric literal to a new PrimRep at compile time. +-- Uses wrapping semantics (same as GHC's integer conversion primops). +-- Returns Nothing for non-numeric literals or unsupported PrimReps. +-- See Note [Constant-folding during unarisation]. +castLiteralArg :: Platform -> PrimRep -> Literal -> Maybe Literal +castLiteralArg platform to_rep (LitNumber _ n) + | Just to_ty <- litNumTypeFromPrimRep to_rep + = Just (mkLitNumberWrap platform to_ty n) +castLiteralArg _ _ _ = Nothing + +litNumTypeFromPrimRep :: PrimRep -> Maybe LitNumType +litNumTypeFromPrimRep WordRep = Just LitNumWord +litNumTypeFromPrimRep Word8Rep = Just LitNumWord8 +litNumTypeFromPrimRep Word16Rep = Just LitNumWord16 +litNumTypeFromPrimRep Word32Rep = Just LitNumWord32 +litNumTypeFromPrimRep Word64Rep = Just LitNumWord64 +litNumTypeFromPrimRep IntRep = Just LitNumInt +litNumTypeFromPrimRep Int8Rep = Just LitNumInt8 +litNumTypeFromPrimRep Int16Rep = Just LitNumInt16 +litNumTypeFromPrimRep Int32Rep = Just LitNumInt32 +litNumTypeFromPrimRep Int64Rep = Just LitNumInt64 +litNumTypeFromPrimRep _ = Nothing + -------------------------------------------------------------------------------- {- ===================================== libraries/base/src/GHC/Stats.hs ===================================== @@ -26,6 +26,7 @@ -- proposal -- #289](https://github.com/haskell/core-libraries-committee/issues/289). These -- declarations are now instead available from the @ghc-experimental@ package. +-- @ghc-experimental@ contains additional metrics not added to the API here. module GHC.Stats ( -- * Runtime statistics ===================================== libraries/base/src/GHC/Weak.hs ===================================== @@ -29,3 +29,5 @@ module GHC.Weak ) where import GHC.Internal.Weak +import GHC.Internal.Weak.Finalize +import GHC.Weak.Finalize ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -14,9 +14,14 @@ module GHC.Weak.Finalize import GHC.Internal.Weak.Finalize --- These imports can be removed once runFinalizerBatch is removed, --- as can MagicHash above. -import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld) +import GHC.Internal.Base +import GHC.Internal.Exception +import GHC.Internal.IORef +import GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId) +import GHC.Internal.IO (catchException, unsafePerformIO) +import GHC.Internal.IO.Handle.Types (Handle) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#) {-# DEPRECATED runFinalizerBatch @@ -36,3 +41,13 @@ runFinalizerBatch :: Int -> Array# (State# RealWorld -> State# RealWorld) -> IO () runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch + +-- | An exception handler for 'Handle' finalization that prints the error to +-- the given 'Handle', but doesn't rethrow it. +-- +-- @since base-4.18.0.0 +printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () +printToHandleFinalizerExceptionHandler hdl se = + hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) + where + msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n" ===================================== libraries/base/src/GHC/Weak/Finalizehs deleted ===================================== ===================================== libraries/base/src/System/Mem/Weak.hs ===================================== @@ -91,6 +91,7 @@ module System.Mem.Weak ( import Prelude import GHC.Internal.Weak +import GHC.Weak -- | A specialised version of 'mkWeak', where the key and the value are -- the same object: ===================================== libraries/base/tests/IO/T17912.hs ===================================== @@ -6,6 +6,7 @@ import Control.Exception import System.IO import System.Exit import System.Process +import GHC.Conc (threadStatus, ThreadStatus(..), BlockReason(..)) import GHC.IO.Handle.FD main = do @@ -22,7 +23,14 @@ main = do putMVar passed True else print e throwIO e - threadDelay 1000 + let waitUntilBlocked = do + st <- threadStatus opener + case st of + ThreadBlocked BlockedOnForeignCall -> return () + ThreadFinished -> return () + ThreadDied -> return () + _ -> threadDelay 100 >> waitUntilBlocked + waitUntilBlocked forkIO $ killThread opener forkIO $ do threadDelay (10^6) ===================================== libraries/base/tests/IO/all.T ===================================== @@ -182,7 +182,7 @@ test('T17414', compile_and_run, ['']) test('T17510', expect_broken(17510), compile_and_run, ['']) test('bytestringread001', extra_run_opts('test.data'), compile_and_run, ['']) -test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(1))], compile_and_run, ['']) +test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(17912))], compile_and_run, ['']) test('T18832', only_ways(['threaded1']), compile_and_run, ['']) test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compile_and_run, ['']) ===================================== libraries/ghc-internal/CHANGELOG.md ===================================== @@ -3,6 +3,7 @@ ## 9.1401.0 -- yyyy-mm-dd * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively. +* Add new `gc_sync_elapsed_ns` counter to GHC.Internal.Stats ## 9.1001.0 -- 2024-05-01 ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs-boot deleted ===================================== @@ -1,70 +0,0 @@ -{-# LANGUAGE MagicHash, NoImplicitPrelude #-} -{-# OPTIONS_HADDOCK not-home #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Conc.Sync [boot] --- Copyright : (c) The University of Glasgow, 1994-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs@haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- Basic concurrency stuff. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Conc.Sync - ( forkIO, - ThreadId(..), - myThreadId, - showThreadId, - ThreadStatus(..), - threadStatus, - sharedCAF, - labelThreadByteArray# - ) where - -import GHC.Internal.Base -import GHC.Internal.Ptr - -forkIO :: IO () -> IO ThreadId - -data ThreadId = ThreadId ThreadId# - -data BlockReason - = BlockedOnMVar - -- ^blocked on 'MVar' - {- possibly (see 'threadstatus' below): - | BlockedOnMVarRead - -- ^blocked on reading an empty 'MVar' - -} - | BlockedOnBlackHole - -- ^blocked on a computation in progress by another thread - | BlockedOnException - -- ^blocked in 'throwTo' - | BlockedOnSTM - -- ^blocked in 'retry' in an STM transaction - | BlockedOnForeignCall - -- ^currently in a foreign call - | BlockedOnOther - -- ^blocked on some other resource. Without @-threaded@, - -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ - -- they show up as 'BlockedOnMVar'. - -data ThreadStatus - = ThreadRunning - -- ^the thread is currently runnable or running - | ThreadFinished - -- ^the thread has finished - | ThreadBlocked BlockReason - -- ^the thread is blocked on some resource - | ThreadDied - -- ^the thread received an uncaught exception - -myThreadId :: IO ThreadId -showThreadId :: ThreadId -> String -threadStatus :: ThreadId -> IO ThreadStatus -sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a -labelThreadByteArray# :: ThreadId -> ByteArray# -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs-boot deleted ===================================== @@ -1,8 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module GHC.Internal.IO.Handle.Text ( hPutStrLn ) where - -import GHC.Internal.Base (String, IO) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Types (Handle) - -hPutStrLn :: Handle -> String -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/Stats.hsc ===================================== @@ -111,6 +111,8 @@ data RTSStats = RTSStats { , gc_cpu_ns :: RtsTime -- | Total elapsed time used by the GC , gc_elapsed_ns :: RtsTime + -- | Total elapsed time used during GC synchronization + , gc_sync_elapsed_ns :: RtsTime -- | Total CPU time (at the previous GC) , cpu_ns :: RtsTime -- | Total elapsed time (at the previous GC) @@ -234,6 +236,7 @@ getRTSStats = do mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p gc_elapsed_ns <- (# peek RTSStats, gc_elapsed_ns) p + gc_sync_elapsed_ns <- (# peek RTSStats, gc_sync_elapsed_ns) p cpu_ns <- (# peek RTSStats, cpu_ns) p elapsed_ns <- (# peek RTSStats, elapsed_ns) p nonmoving_gc_sync_cpu_ns <- (# peek RTSStats, nonmoving_gc_sync_cpu_ns) p ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Internal.IO.Handle import GHC.Internal.IO.StdHandles import GHC.Internal.IO.Exception import GHC.Internal.Weak +import GHC.Internal.Weak.Finalize +import GHC.Internal.IO.Handle.Types () #if defined(mingw32_HOST_OS) import GHC.Internal.ConsoleHandler as GHC.ConsoleHandler ===================================== libraries/ghc-internal/src/GHC/Internal/Weak.hs ===================================== @@ -24,19 +24,9 @@ module GHC.Internal.Weak ( mkWeak, deRefWeak, finalize, - - -- * Handling exceptions - -- | When an exception is thrown by a finalizer called by the - -- garbage collector, GHC calls a global handler which can be set with - -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by - -- this handler will be ignored. - setFinalizerExceptionHandler, - getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler ) where import GHC.Internal.Base -import GHC.Internal.Weak.Finalize {-| A weak pointer object with a key and a value. The value has type @v@. ===================================== libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs ===================================== @@ -4,26 +4,17 @@ {-# LANGUAGE Unsafe #-} module GHC.Internal.Weak.Finalize - ( -- * Handling exceptions - -- | When an exception is thrown by a finalizer called by the - -- garbage collector, GHC calls a global handler which can be set with - -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by - -- this handler will be ignored. - setFinalizerExceptionHandler - , getFinalizerExceptionHandler - , printToHandleFinalizerExceptionHandler - -- * Internal + ( getFinalizerExceptionHandler + , setFinalizerExceptionHandler , runFinalizerBatch ) where import GHC.Internal.Base -import GHC.Internal.Exception -import GHC.Internal.IORef -import {-# SOURCE #-} GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId) -import GHC.Internal.IO (catchException, unsafePerformIO) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Types (Handle) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Text (hPutStrLn) -import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#) +import GHC.Internal.Conc.Sync ( labelThreadByteArray#, myThreadId ) +import GHC.Internal.Encoding.UTF8 ( utf8EncodeByteArray# ) +import GHC.Internal.Exception ( SomeException(..) ) +import GHC.Internal.IO ( catchException, unsafePerformIO ) +import GHC.Internal.IORef ( IORef, newIORef, readIORef, writeIORef ) data ByteArray = ByteArray ByteArray# @@ -82,13 +73,3 @@ getFinalizerExceptionHandler = readIORef finalizerExceptionHandler -- @since base-4.18.0.0 setFinalizerExceptionHandler :: (SomeException -> IO ()) -> IO () setFinalizerExceptionHandler = writeIORef finalizerExceptionHandler - --- | An exception handler for 'Handle' finalization that prints the error to --- the given 'Handle', but doesn't rethrow it. --- --- @since base-4.18.0.0 -printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () -printToHandleFinalizerExceptionHandler hdl se = - hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) - where - msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n" ===================================== libraries/template-haskell/Language/Haskell/TH/Quote.hs ===================================== @@ -23,7 +23,6 @@ module Language.Haskell.TH.Quote ) where import GHC.Boot.TH.Monad -import GHC.Boot.TH.Quote import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) ===================================== rts/Stats.c ===================================== @@ -163,6 +163,7 @@ initStats0(void) .mutator_elapsed_ns = 0, .gc_cpu_ns = 0, .gc_elapsed_ns = 0, + .gc_sync_elapsed_ns = 0, .cpu_ns = 0, .elapsed_ns = 0, .nonmoving_gc_cpu_ns = 0, @@ -288,6 +289,8 @@ stat_endExit(void) RELEASE_LOCK(&stats_mutex); } +// This is only called in the threaded RTS. On non-threaded RTS `gc_sync_start_elapsed` +// is conditonally set in `stat_startGC`. void stat_startGCSync (gc_thread *gct) { @@ -433,6 +436,11 @@ stat_startGC (Capability *cap, gc_thread *gct) } gct->gc_start_elapsed = getProcessElapsedTime(); +#if !defined(THREADED_RTS) + // Non-threaded RTS has no sync phase. Initializing in this way makes the + // calculated statistics correctly read zero. + gct->gc_sync_start_elapsed = gct->gc_start_elapsed; +#endif // Post EVENT_GC_START with the same timestamp as used for stats // (though converted from Time=StgInt64 to EventTimestamp=StgWord64). @@ -548,6 +556,7 @@ stat_endGC (Capability *cap, gc_thread *initiating_gct, W_ live, W_ copied, W_ s } stats.gc_cpu_ns += stats.gc.cpu_ns; stats.gc_elapsed_ns += stats.gc.elapsed_ns; + stats.gc_sync_elapsed_ns += stats.gc.sync_elapsed_ns; if (gen == RtsFlags.GcFlags.generations-1) { // major GC? stats.major_gcs++; @@ -915,6 +924,8 @@ static void report_summary(const RTSSummaryStats* sum) statsPrintf(" GC time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(stats.gc_cpu_ns), TimeToSecondsDbl(stats.gc_elapsed_ns)); + statsPrintf(" GC SYNC time (%7.3fs elapsed)\n", + TimeToSecondsDbl(stats.gc_sync_elapsed_ns)); if (RtsFlags.GcFlags.useNonmoving) { statsPrintf( " CONC GC time %7.3fs (%7.3fs elapsed)\n", @@ -1069,6 +1080,7 @@ static void report_machine_readable (const RTSSummaryStats * sum) TimeToSecondsDbl(stats.mutator_elapsed_ns)); MR_STAT("GC_cpu_seconds", "f", TimeToSecondsDbl(stats.gc_cpu_ns)); MR_STAT("GC_wall_seconds", "f", TimeToSecondsDbl(stats.gc_elapsed_ns)); + MR_STAT("GC_sync_wall_seconds", "f", TimeToSecondsDbl(stats.gc_sync_elapsed_ns)); // end backward compatibility ===================================== rts/include/RtsAPI.h ===================================== @@ -240,6 +240,8 @@ typedef struct _RTSStats { Time gc_cpu_ns; // Total elapsed time used by the GC Time gc_elapsed_ns; + // Total elapsed time used during GC synchronization + Time gc_sync_elapsed_ns; // Total CPU time (at the previous GC) Time cpu_ns; // Total elapsed time (at the previous GC) ===================================== testsuite/tests/codeGen/should_compile/Makefile ===================================== @@ -80,3 +80,6 @@ T17648: T25166: '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25166.hs | awk '/foo_closure/{flag=1}/}]/{flag=0}flag' + +T25650: + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25650.hs | awk '/baz_foo_closure|baz_bar_closure/{flag=1}/}]/{flag=0}flag' ===================================== testsuite/tests/codeGen/should_compile/T25650.hs ===================================== @@ -0,0 +1,17 @@ +module T25650 (baz_foo, baz_bar) where + +import Data.Word + +data A + = A1 {-# UNPACK #-} !Word32 + | A2 {-# UNPACK #-} !B + +data B = B1 | B2 + +foo = A1 10 +bar = A2 B2 + +data C = C {-# UNPACK #-} !A + +baz_foo = C foo +baz_bar = C bar ===================================== testsuite/tests/codeGen/should_compile/T25650.stdout ===================================== @@ -0,0 +1,14 @@ +[section ""data" . T25650.baz_foo_closure" { + T25650.baz_foo_closure: + const T25650.C_con_info; + const 10 :: W32; + const 1 :: W8; + const 0 :: W8; + const 0 :: W16; +[section ""data" . T25650.baz_bar_closure" { + T25650.baz_bar_closure: + const T25650.C_con_info; + const 2 :: W32; + const 2 :: W8; + const 0 :: W8; + const 0 :: W16; ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -140,6 +140,7 @@ test('callee-no-local', [ ) test('T25166', [req_cmm], makefile_test, []) +test('T25650', [req_cmm], makefile_test, []) # dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep) test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0']) ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -6587,6 +6587,7 @@ module GHC.Stats.Experimental where mutator_elapsed_ns :: RtsTime, gc_cpu_ns :: RtsTime, gc_elapsed_ns :: RtsTime, + gc_sync_elapsed_ns :: RtsTime, cpu_ns :: RtsTime, elapsed_ns :: RtsTime, nonmoving_gc_sync_cpu_ns :: RtsTime, ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -6590,6 +6590,7 @@ module GHC.Stats.Experimental where mutator_elapsed_ns :: RtsTime, gc_cpu_ns :: RtsTime, gc_elapsed_ns :: RtsTime, + gc_sync_elapsed_ns :: RtsTime, cpu_ns :: RtsTime, elapsed_ns :: RtsTime, nonmoving_gc_sync_cpu_ns :: RtsTime, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cba550060ae73e5abfd6ab03c9402a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cba550060ae73e5abfd6ab03c9402a... You're receiving this email because of your account on gitlab.haskell.org.