GitLab

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 <conversion_primop> arg of x' -> <rhs using 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

 -{-# 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

 -{-# 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

 +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

 +[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,