GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

d046b5ab

by Simon Hengel at 2025-07-24T06:12:05-04:00

Include the rendered message in -fdiagnostics-as-json output

This implements #26173.

d2b89603

by Ben Gamari at 2025-07-24T06:12:47-04:00

rts/Interpreter: Factor out ctoi tuple info tables into data

Instead of a massive case let's put this into data which we can reuse
elsewhere.

8d3ce71a

by Sebastian Graf at 2025-07-24T09:48:46-04:00

CprAnal: Detect recursive newtypes (#25944)

While `cprTransformDataConWork` handles recursive data con workers, it
did not detect the case when a newtype is responsible for the recursion.
This is now detected in the `Cast` case of `cprAnal`.

The same reproducer made it clear that `isRecDataCon` lacked congruent
handling for `AppTy` and `CastTy`, now fixed.

Furthermore, the new repro case T25944 triggered this bug via an
infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`.
While it should be much less likely to trigger such an infinite loop now
that `isRecDataCon` has been fixed, I made sure to abort the loop after
10 iterations and emitting a warning instead.

Fixes #25944.

c8c9416e

by Sylvain Henry at 2025-07-24T09:49:08-04:00

STM: don't create a transaction in the rhs of catchRetry# (#26028)

We don't need to create a transaction for the rhs of (catchRetry#)
because contrary to the lhs we don't need to abort it on retry. Moreover
it is particularly harmful if we have code such as (#26028):

  let cN = readTVar vN >> retry
      tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...))
  atomically tree

Because it will stack transactions for the rhss and the read-sets of all
the transactions will be iteratively merged in O(n^2) after the
execution of the most nested retry.

20 changed files:

compiler/GHC/Core/Opt/CprAnal.hs
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
compiler/GHC/Driver/Errors.hs
compiler/GHC/Types/Error.hs
compiler/GHC/Utils/Logger.hs
docs/users_guide/9.14.1-notes.rst
+ docs/users_guide/diagnostics-as-json-schema-1_2.json
docs/users_guide/using.rst
rts/Interpreter.c
rts/PrimOps.cmm
rts/RaiseAsync.c
rts/STM.c
+ testsuite/tests/cpranal/sigs/T25944.hs
+ testsuite/tests/cpranal/sigs/T25944.stderr
testsuite/tests/cpranal/sigs/all.T
testsuite/tests/driver/json.stderr
testsuite/tests/driver/json_warn.stderr
+ testsuite/tests/lib/stm/T26028.hs
+ testsuite/tests/lib/stm/T26028.stdout
+ testsuite/tests/lib/stm/all.T

Changes:

compiler/GHC/Core/Opt/CprAnal.hs

 +{-# LANGUAGE MultiWayIf #-}
  -- | Constructed Product Result analysis. Identifies functions that surely
  -- return heap-allocated records on every code path, so that we can eliminate
@@ -22,12 +23,15 @@ import GHC.Types.Demand
  import GHC.Types.Cpr
  import GHC.Types.Unique.MemoFun
 +import GHC.Core
  import GHC.Core.FamInstEnv
  import GHC.Core.DataCon
  import GHC.Core.Type
  import GHC.Core.Utils
 -import GHC.Core
 +import GHC.Core.Coercion
 +import GHC.Core.Reduction
  import GHC.Core.Seq
 +import GHC.Core.TyCon
  import GHC.Core.Opt.WorkWrap.Utils
  import GHC.Data.Graph.UnVar -- for UnVarSet
@@ -216,9 +220,13 @@ cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact
  cprAnal' _ (Coercion co) = (topCprType, Coercion co)
  cprAnal' env (Cast e co)
 -  = (cpr_ty, Cast e' co)
 +  = (cpr_ty', Cast e' co)
    where
      (cpr_ty, e') = cprAnal env e
 +    cpr_ty'
 +      | cpr_ty == topCprType                    = topCprType -- cheap case first
 +      | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]
 +      | otherwise                               = cpr_ty
  cprAnal' env (Tick t e)
    = (cpr_ty, Tick t e')
@@ -391,6 +399,19 @@ cprTransformDataConWork env con args
  mAX_CPR_SIZE :: Arity
  mAX_CPR_SIZE = 10
 +isRecNewTyConApp :: AnalEnv -> Type -> Bool
 +-- See Note [CPR for recursive newtype constructors]
 +isRecNewTyConApp env ty
 +  --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined
 +  | Just (tc, tc_args) <- splitTyConApp_maybe ty =
 +      if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args
 +         -> isRecNewTyConApp env rhs
 +         | Just dc <- newTyConDataCon_maybe tc
 +         -> ae_rec_dc env dc == DefinitelyRecursive
 +         | otherwise
 +         -> False
 +  | otherwise = False
++
  --
  -- * Bindings
  --
@@ -414,12 +435,18 @@ cprFix orig_env orig_pairs
                 | otherwise    = orig_pairs
      init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
 +    -- If fixed-point iteration does not yield a result we use this instead
 +    -- See Note [Safe abortion in the fixed-point iteration]
 +    abort :: (AnalEnv, [(Id,CoreExpr)])
 +    abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ]
++
      -- The fixed-point varies the idCprSig field of the binders and and their
      -- entries in the AnalEnv, and terminates if that annotation does not change
      -- any more.
      loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
      loop n env pairs
        | found_fixpoint = (reset_env', pairs')
 +      | n == 10        = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort
        | otherwise      = loop (n+1) env' pairs'
        where
          -- In all but the first iteration, delete the virgin flag
@@ -519,8 +546,9 @@ cprAnalBind env id rhs
      -- possibly trim thunk CPR info
      rhs_ty'
        -- See Note [CPR for thunks]
 -      | stays_thunk = trimCprTy rhs_ty
 -      | otherwise   = rhs_ty
 +      | rhs_ty == topCprType = topCprType -- cheap case first
 +      | stays_thunk          = trimCprTy rhs_ty
 +      | otherwise            = rhs_ty
      -- See Note [Arity trimming for CPR signatures]
      sig  = mkCprSigForArity (idArity id) rhs_ty'
      -- See Note [OPAQUE pragma]
@@ -639,7 +667,7 @@ data AnalEnv
    , ae_fam_envs :: FamInstEnvs
    -- ^ Needed when expanding type families and synonyms of product types.
    , ae_rec_dc :: DataCon -> IsRecDataConResult
 -  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
 +  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType
+   }
  instance Outputable AnalEnv where
@@ -1042,10 +1070,11 @@ Eliminating the shared 'c' binding in the process. And then
  What can we do about it?
 - A. Don't CPR functions that return a *recursive data type* (the list in this
 -    case). This is the solution we adopt. Rationale: the benefit of CPR on
 -    recursive data structures is slight, because it only affects the outer layer
 -    of a potentially massive data structure.
 + A. Don't give recursive data constructors or casts representing recursive newtype constructors
 +    the CPR property (the list in this case). This is the solution we adopt.
 +    Rationale: the benefit of CPR on recursive data structures is slight,
 +    because it only affects the outer layer of a potentially massive data
 +    structure.
   B. Don't CPR any *recursive function*. That would be quite conservative, as it
      would also affect e.g. the factorial function.
   C. Flat CPR only for recursive functions. This prevents the asymptotic
@@ -1055,10 +1084,15 @@ What can we do about it?
      `c` in the second eqn of `replicateC`). But we'd need to know which paths
      were hot. We want such static branch frequency estimates in #20378.
 -We adopt solution (A) It is ad-hoc, but appears to work reasonably well.
 -Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:
 -See Note [Detecting recursive data constructors]. We don't have to be perfect
 -and can simply keep on unboxing if unsure.
 +We adopt solution (A). It is ad-hoc, but appears to work reasonably well.
 +Specifically:
++
 +* For data constructors, in `cprTransformDataConWork` we check for a recursive
 +  data constructor by calling `ae_rec_dc env`, which is just a memoised version
 +  of `isRecDataCon`.  See Note [Detecting recursive data constructors]
 +* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype
 +  by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.
 +  See Note [CPR for recursive newtype constructors]
  Note [Detecting recursive data constructors]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1075,12 +1109,15 @@ looks inside the following class of types, represented by `ty` (and responds
      types of its data constructors and check `tc_args` for recursion.
   C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to
      `rhs`, look into the `rhs` type.
 + D. If `ty = f a`, then look into `f` and `a`
 + E. If `ty = ty' |> co`, then look into `ty'`
  A few perhaps surprising points:
 . It deems any function type as non-recursive, because it's unlikely that
       a recursion through a function type builds up a recursive data structure.
 -  2. It doesn't look into kinds or coercion types because there's nothing to unbox.
 +  2. It doesn't look into kinds, literals or coercion types because we are
 +     ultimately looking for value-level recursion.
       Same for promoted data constructors.
 . We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;
       we simply look at its definition/DataCons and its field tys and look for
@@ -1153,6 +1190,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon'
  configurable like (4) to enable more re-use throughout the compiler, but haven't
  found a killer app for that yet, so ultimately didn't do that.
 +Note [CPR for recursive newtype constructors]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +A newtype constructor is considered recursive iff the data constructor of the
 +equivalent datatype definition is recursive.
 +See Note [CPR for recursive data constructors].
 +Detection is a bit complicated by the fact that newtype constructor applications
 +reflect as Casts in Core:
++
 +  newtype List a = C (Maybe (a, List a))
 +  xs = C (Just (0, C Nothing))
 +  ==> {desugar to Core}
 +  xs = Just (0, Nothing |> sym N:List) |> sym N:List
++
 +So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than
 +in `cprTransformDataConWork` as for data constructors.
++
  Note [CPR examples]
  ~~~~~~~~~~~~~~~~~~~
  Here are some examples (stranal/should_compile/T10482a) of the

compiler/GHC/Core/Opt/WorkWrap/Utils.hs

@@ -63,6 +63,7 @@ import Data.List ( unzip4 )
  import GHC.Types.RepType
  import GHC.Unit.Types
 +import GHC.Core.TyCo.Rep
  {-
  ************************************************************************
@@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc
                      | arg_ty <- map scaledThing (dataConRepArgTys dc) ]
      go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
 -    go_arg_ty fuel visited_tcs ty
 -      --- | pprTrace "arg_ty" (ppr ty) False = undefined
 +    go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $
 +      case coreFullView ty of
 +        TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args
 +          -- See Note [Detecting recursive data constructors], points (B) and (C)
 -      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty
 -      = go_arg_ty fuel visited_tcs ty'
 +        ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'
            -- See Note [Detecting recursive data constructors], point (A)
 -      | Just (tc, tc_args) <- splitTyConApp_maybe ty
 -      = go_tc_app fuel visited_tcs tc tc_args
 +        CastTy ty' _ -> go_arg_ty fuel visited_tcs ty'
 -      | otherwise
 -      = NonRecursiveOrUnsure
 +        AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a
 +          -- See Note [Detecting recursive data constructors], point (D)
++
 +        FunTy{} -> NonRecursiveOrUnsure
 +          -- See Note [Detecting recursive data constructors], point (1)
++
 +        -- (TyVarTy{} | LitTy{} | CastTy{})
 +        _ -> NonRecursiveOrUnsure
      go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
      go_tc_app fuel visited_tcs tc tc_args =
        case tyConDataCons_maybe tc of
 -      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
 +        ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined
          _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
            -- This is the only place where we look at tc_args, which might have
            -- See Note [Detecting recursive data constructors], point (C) and (5)

compiler/GHC/Driver/Errors.hs

@@ -12,6 +12,7 @@ import GHC.Prelude
  import GHC.Types.SrcLoc
  import GHC.Types.SourceError
  import GHC.Types.Error
 +import GHC.Utils.Json
  import GHC.Utils.Error
  import GHC.Utils.Outputable
  import GHC.Utils.Logger
@@ -46,9 +47,22 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
  printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
  printMessage logger msg_opts opts message
 -  | log_diags_as_json = logJsonMsg logger messageClass message
 +  | log_diags_as_json = do
 +      decorated <- decorateDiagnostic logflags messageClass location doc
 +      let
 +        rendered :: String
 +        rendered = renderWithContext (log_default_user_context logflags) decorated
++
 +        jsonMessage :: JsonDoc
 +        jsonMessage = jsonDiagnostic rendered message
++
 +      logJsonMsg logger messageClass jsonMessage
++
    | otherwise = logMsg logger messageClass location doc
    where
 +    logflags :: LogFlags
 +    logflags = logFlags logger
++
      doc :: SDoc
      doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)

compiler/GHC/Types/Error.hs

@@ -73,6 +73,9 @@ module GHC.Types.Error
     , mkLocMessage
     , mkLocMessageWarningGroups
     , getCaretDiagnostic
++
 +   , jsonDiagnostic
++
     -- * Queries
     , isIntrinsicErrorMessage
     , isExtrinsicErrorMessage
@@ -109,7 +112,7 @@ import GHC.Utils.Panic
  import GHC.Version (cProjectVersion)
  import Data.Bifunctor
 -import Data.Foldable    ( fold, toList )
 +import Data.Foldable
  import Data.List.NonEmpty ( NonEmpty (..) )
  import qualified Data.List.NonEmpty as NE
  import Data.List ( intercalate )
@@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where
                 pprDiagnostic (errMsgDiagnostic envelope)
+              ]
 -instance (Diagnostic e) => ToJson (Messages e) where
 -  json msgs =  JSArray . toList $ json <$> getMessages msgs
+-
  {- Note [Discarding Messages]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
  {- Note [Diagnostic Message JSON Schema]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  The below instance of ToJson must conform to the JSON schema
 -specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
 +specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
  When the schema is altered, please bump the version.
  If the content is altered in a backwards compatible way,
  update the minor version (e.g. 1.3 ~> 1.4).
@@ -586,15 +586,17 @@ https://json-schema.org
  -}
  schemaVersion :: String
 -schemaVersion = "1.1"
 +schemaVersion = "1.2"
++
  -- See Note [Diagnostic Message JSON Schema] before editing!
 -instance Diagnostic e => ToJson (MsgEnvelope e) where
 -  json m = JSObject $ [
 +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
 +jsonDiagnostic rendered m = JSObject $ [
      ("version", JSString schemaVersion),
      ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
      ("span", json $ errMsgSpan m),
      ("severity", json $ errMsgSeverity m),
      ("code", maybe JSNull json (diagnosticCode diag)),
 +    ("rendered", JSString rendered),
      ("message", JSArray $ map renderToJSString diagMsg),
      ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
      ++ [ ("reason", reasonJson)

compiler/GHC/Utils/Logger.hs

@@ -62,6 +62,8 @@ module GHC.Utils.Logger
      , logJsonMsg
      , logDumpMsg
 +    , decorateDiagnostic
++
      -- * Dumping
      , defaultDumpAction
      , putDumpFile
@@ -419,26 +421,62 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
        MCInfo                       -> printErrs msg
        MCFatal                      -> printErrs msg
        MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message
 -      MCDiagnostic _sev _rea _code -> printDiagnostics
 +      MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
      where
        printOut   = defaultLogActionHPrintDoc  logflags False out
        printErrs  = defaultLogActionHPrintDoc  logflags False err
        putStrSDoc = defaultLogActionHPutStrDoc logflags False out
++
 +-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
 +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
 +-- message on `-fdiagnostics-as-json`.
 +--
 +-- We would want to eventually consolidate this.  However, this is currently
 +-- not feasible for the following reasons:
 +--
 +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
 +--    can not decorate the message in `printMessages`.
 +--
 +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
 +--    that reason we can not decorate the message in `defaultLogActionWithHandles`.
 +--
 +--    See also Note [JSON Error Messages]:
 +--
 +--      `jsonLogAction` should be removed along with -ddump-json
 +--
 +-- Also note that (1) is the reason why some parts of the compiler produce
 +-- diagnostics that don't respect `-fdiagnostics-as-json`.
 +--
 +-- The plan as I see it is as follows:
 +--
 +--  1. Refactor all places in the compiler that report diagnostics to go
 +--     through `GHC.Driver.Errors.printMessages`.
 +--
 +--     (It's easy to find all those places by looking for who creates
 +--     MCDiagnostic, either directly or via `mkMCDiagnostic` or
 +--     `errorDiagnostic`.)
 +--
 +--  2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
 +--     decoration at one place (either `printMessages` or
 +--     `defaultLogActionWithHandles`)
 +--
 +-- This story is tracked by #24113.
 +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
 +decorateDiagnostic logflags msg_class srcSpan msg = addCaret
 +    where
        -- Pretty print the warning flag, if any (#10752)
 +      message :: SDoc
        message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
 -      printDiagnostics = do
 +      addCaret :: IO SDoc
 +      addCaret = do
          caretDiagnostic <-
              if log_show_caret logflags
              then getCaretDiagnostic msg_class srcSpan
              else pure empty
 -        printErrs $ getPprStyle $ \style ->
 +        return $ getPprStyle $ \style ->
            withPprStyle (setStyleColoured True style)
              (message $+$ caretDiagnostic $+$ blankLine)
 -        -- careful (#2302): printErrs prints in UTF-8,
 -        -- whereas converting to string first and using
 -        -- hPutStr would just emit the low 8 bits of
 -        -- each unicode char.
  -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
  defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
@@ -603,8 +641,8 @@ defaultTraceAction logflags title doc x =
  logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
  logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
 -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
 -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)
 +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
 +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
  -- | Dump something
  logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

docs/users_guide/9.14.1-notes.rst

@@ -147,6 +147,11 @@ Compiler
    integer operations.  Also, ``shuffleFloatX4#`` and ``shuffleDoubleX2#`` no longer
    require ``-mavx``.
 +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
 +  include the `rendered` diagnostics message, in the exact same format as what
 +  GHC would have produced without -fdiagnostics-as-json (including ANSI escape
 +  sequences).
++
  GHCi
  ~~~~

docs/users_guide/diagnostics-as-json-schema-1_2.json

 +{
 +  "$schema": "https://json-schema.org/draft/2020-12/schema",
 +  "title": "JSON Diagnostic Schema",
 +  "description": "A Schema for specifying GHC diagnostics output as JSON",
 +  "type": "object",
 +  "properties": {
 +    "version": {
 +      "description": "The current JSON schema version this object conforms to",
 +      "type": "string"
 +    },
 +    "ghcVersion": {
 +      "description": "The GHC version",
 +      "type": "string"
 +    },
 +    "span": {
 +      "oneOf": [
 +        { "$ref": "#/$defs/span" },
 +        { "type": "null" }
 +      ]
 +    },
 +    "severity": {
 +      "description": "The diagnostic severity",
 +      "type": "string",
 +      "enum": [
 +        "Warning",
 +        "Error"
 +      ]
 +    },
 +    "code": {
 +      "description": "The diagnostic code (if it exists)",
 +      "type": [
 +        "integer",
 +        "null"
 +      ]
 +    },
 +    "rendered": {
 +      "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
 +      "type": "string"
 +    },
 +    "message": {
 +      "description": "The string output of the diagnostic message by GHC",
 +      "type": "array",
 +      "items": {
 +        "type": "string"
 +      }
 +    },
 +    "hints": {
 +      "description": "The suggested fixes",
 +      "type": "array",
 +      "items": {
 +        "type": "string"
 +      }
 +    },
 +    "reason" : {
 +      "description": "The GHC flag that was responsible for the emission of the diagnostic message",
 +      "oneOf": [
 +        {
 +          "type": "object",
 +          "description": "The diagnostic message was controlled by one or more GHC flags",
 +          "properties": {
 +            "flags": {
 +              "type": "array",
 +              "items": {
 +                "description": "The name of a GHC flag controlling the diagnostic message",
 +                "type": "string"
 +              },
 +              "minItems": 1
 +            }
 +          },
 +          "required": ["flags"]
 +        },
 +        {
 +          "type": "object",
 +          "description": "The diagnostic message was controlled by a GHC diagnostic message category",
 +          "properties": {
 +            "category": {
 +              "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
 +              "type": "string"
 +            }
 +          },
 +          "required": ["category"]
 +        }
 +      ]
 +    }
 +  },
++
 +  "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.",
 +  "required": [
 +    "version",
 +    "ghcVersion",
 +    "span",
 +    "severity",
 +    "code",
 +    "message",
 +    "hints"
 +  ],
++
 +  "additionalProperties": false,
 +  "$defs": {
 +    "span": {
 +      "description": "The span of the diagnostic",
 +      "type": "object",
 +      "properties": {
 +        "file": {
 +          "description": "The file in which the diagnostic occurs",
 +          "type": "string"
 +        },
 +        "start": {
 +          "description": "The start location of the diagnostic",
 +          "$ref": "#/$defs/location"
 +        },
 +        "end": {
 +          "description": "The end location of the diagnostic",
 +          "$ref": "#/$defs/location"
 +        }
 +      },
 +      "required": [
 +        "file",
 +        "start",
 +        "end"
 +      ],
 +      "additionalProperties": false
 +    },
 +    "location": {
 +      "description": "A location in a text file",
 +      "type": "object",
 +      "properties": {
 +        "line": {
 +          "description": "The line number",
 +          "type": "integer"
 +        },
 +        "column": {
 +          "description": "The column number",
 +          "type": "integer"
 +        }
 +      },
 +      "required": [
 +        "line",
 +        "column"
 +      ],
 +      "additionalProperties": false
 +    }
 +  }
 +}

docs/users_guide/using.rst

@@ -1428,7 +1428,7 @@ messages and in GHCi:
      a new line.
      The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
 -    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
 +    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`.
  .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
      :shortdesc: Use colors in error messages

rts/Interpreter.c

@@ -473,6 +473,72 @@ void interp_shutdown( void ){
  #endif
 +const StgPtr ctoi_tuple_infos[] = {
 +    (StgPtr) &stg_ctoi_t0_info,
 +    (StgPtr) &stg_ctoi_t1_info,
 +    (StgPtr) &stg_ctoi_t2_info,
 +    (StgPtr) &stg_ctoi_t3_info,
 +    (StgPtr) &stg_ctoi_t4_info,
 +    (StgPtr) &stg_ctoi_t5_info,
 +    (StgPtr) &stg_ctoi_t6_info,
 +    (StgPtr) &stg_ctoi_t7_info,
 +    (StgPtr) &stg_ctoi_t8_info,
 +    (StgPtr) &stg_ctoi_t9_info,
 +    (StgPtr) &stg_ctoi_t10_info,
 +    (StgPtr) &stg_ctoi_t11_info,
 +    (StgPtr) &stg_ctoi_t12_info,
 +    (StgPtr) &stg_ctoi_t13_info,
 +    (StgPtr) &stg_ctoi_t14_info,
 +    (StgPtr) &stg_ctoi_t15_info,
 +    (StgPtr) &stg_ctoi_t16_info,
 +    (StgPtr) &stg_ctoi_t17_info,
 +    (StgPtr) &stg_ctoi_t18_info,
 +    (StgPtr) &stg_ctoi_t19_info,
 +    (StgPtr) &stg_ctoi_t20_info,
 +    (StgPtr) &stg_ctoi_t21_info,
 +    (StgPtr) &stg_ctoi_t22_info,
 +    (StgPtr) &stg_ctoi_t23_info,
 +    (StgPtr) &stg_ctoi_t24_info,
 +    (StgPtr) &stg_ctoi_t25_info,
 +    (StgPtr) &stg_ctoi_t26_info,
 +    (StgPtr) &stg_ctoi_t27_info,
 +    (StgPtr) &stg_ctoi_t28_info,
 +    (StgPtr) &stg_ctoi_t29_info,
 +    (StgPtr) &stg_ctoi_t30_info,
 +    (StgPtr) &stg_ctoi_t31_info,
 +    (StgPtr) &stg_ctoi_t32_info,
 +    (StgPtr) &stg_ctoi_t33_info,
 +    (StgPtr) &stg_ctoi_t34_info,
 +    (StgPtr) &stg_ctoi_t35_info,
 +    (StgPtr) &stg_ctoi_t36_info,
 +    (StgPtr) &stg_ctoi_t37_info,
 +    (StgPtr) &stg_ctoi_t38_info,
 +    (StgPtr) &stg_ctoi_t39_info,
 +    (StgPtr) &stg_ctoi_t40_info,
 +    (StgPtr) &stg_ctoi_t41_info,
 +    (StgPtr) &stg_ctoi_t42_info,
 +    (StgPtr) &stg_ctoi_t43_info,
 +    (StgPtr) &stg_ctoi_t44_info,
 +    (StgPtr) &stg_ctoi_t45_info,
 +    (StgPtr) &stg_ctoi_t46_info,
 +    (StgPtr) &stg_ctoi_t47_info,
 +    (StgPtr) &stg_ctoi_t48_info,
 +    (StgPtr) &stg_ctoi_t49_info,
 +    (StgPtr) &stg_ctoi_t50_info,
 +    (StgPtr) &stg_ctoi_t51_info,
 +    (StgPtr) &stg_ctoi_t52_info,
 +    (StgPtr) &stg_ctoi_t53_info,
 +    (StgPtr) &stg_ctoi_t54_info,
 +    (StgPtr) &stg_ctoi_t55_info,
 +    (StgPtr) &stg_ctoi_t56_info,
 +    (StgPtr) &stg_ctoi_t57_info,
 +    (StgPtr) &stg_ctoi_t58_info,
 +    (StgPtr) &stg_ctoi_t59_info,
 +    (StgPtr) &stg_ctoi_t60_info,
 +    (StgPtr) &stg_ctoi_t61_info,
 +    (StgPtr) &stg_ctoi_t62_info,
 +};
++
  #if defined(PROFILING)
  //
@@ -1828,82 +1894,11 @@ run_BCO:
              SpW(-1) = BCO_PTR(o_tuple_bco);
              SpW(-2) = tuple_info;
              SpW(-3) = BCO_PTR(o_bco);
 -            W_ ctoi_t_offset;
              int tuple_stack_words = (tuple_info >> 24) & 0xff;
 -            switch(tuple_stack_words) {
 -                case 0:  ctoi_t_offset = (W_)&stg_ctoi_t0_info;  break;
 -                case 1:  ctoi_t_offset = (W_)&stg_ctoi_t1_info;  break;
 -                case 2:  ctoi_t_offset = (W_)&stg_ctoi_t2_info;  break;
 -                case 3:  ctoi_t_offset = (W_)&stg_ctoi_t3_info;  break;
 -                case 4:  ctoi_t_offset = (W_)&stg_ctoi_t4_info;  break;
 -                case 5:  ctoi_t_offset = (W_)&stg_ctoi_t5_info;  break;
 -                case 6:  ctoi_t_offset = (W_)&stg_ctoi_t6_info;  break;
 -                case 7:  ctoi_t_offset = (W_)&stg_ctoi_t7_info;  break;
 -                case 8:  ctoi_t_offset = (W_)&stg_ctoi_t8_info;  break;
 -                case 9:  ctoi_t_offset = (W_)&stg_ctoi_t9_info;  break;
+-
 -                case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
 -                case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
 -                case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
 -                case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
 -                case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
 -                case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
 -                case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
 -                case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
 -                case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
 -                case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
+-
 -                case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
 -                case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
 -                case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
 -                case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
 -                case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
 -                case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
 -                case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
 -                case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
 -                case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
 -                case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
+-
 -                case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
 -                case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
 -                case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
 -                case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
 -                case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
 -                case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
 -                case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
 -                case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
 -                case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
 -                case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
+-
 -                case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
 -                case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
 -                case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
 -                case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
 -                case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
 -                case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
 -                case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
 -                case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
 -                case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
 -                case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
+-
 -                case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
 -                case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
 -                case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
 -                case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
 -                case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
 -                case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
 -                case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
 -                case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
 -                case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
 -                case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
+-
 -                case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
 -                case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
 -                case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
+-
 -                default: barf("unsupported tuple size %d", tuple_stack_words);
 +            if (tuple_stack_words > 62) {
 +                barf("unsupported tuple size %d", tuple_stack_words);
+             }
+-
 +            W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
              SpW(-4) = ctoi_t_offset;
              Sp_subW(4);
              goto nextInsn;

rts/PrimOps.cmm

@@ -1211,16 +1211,27 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
      gcptr trec, outer, arg;
      trec = StgTSO_trec(CurrentTSO);
 -    outer  = StgTRecHeader_enclosing_trec(trec);
 -    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 -    if (r != 0) {
 -        // Succeeded (either first branch or second branch)
 -        StgTSO_trec(CurrentTSO) = outer;
 -        return (ret);
 -    } else {
 -        // Did not commit: abort and restart.
 -        StgTSO_trec(CurrentTSO) = outer;
 -        jump stg_abort();
 +    if (running_alt_code != 1) {
 +      // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
 +      // the nested transaction.
 +      // See Note [catchRetry# implementation]
 +      outer  = StgTRecHeader_enclosing_trec(trec);
 +      (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 +      if (r != 0) {
 +          // Succeeded in first branch
 +          StgTSO_trec(CurrentTSO) = outer;
 +          return (ret);
 +      } else {
 +          // Did not commit: abort and restart.
 +          StgTSO_trec(CurrentTSO) = outer;
 +          jump stg_abort();
 +      }
 +    }
 +    else {
 +      // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
 +      // using the parent transaction (not a nested one).
 +      // See Note [catchRetry# implementation]
 +      return (ret);
+     }
+ }
@@ -1453,21 +1464,26 @@ retry_pop_stack:
      outer  = StgTRecHeader_enclosing_trec(trec);
      if (frame_type == CATCH_RETRY_FRAME) {
 -        // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
 -        ASSERT(outer != NO_TREC);
 -        // Abort the transaction attempting the current branch
 -        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 -        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
 +        // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
++
          if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
 -            // Retry in the first branch: try the alternative
 -            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
 -            StgTSO_trec(CurrentTSO) = trec;
 +            // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
 +            // transaction. See Note [catchRetry# implementation]
++
 +            // check that we have a parent transaction
 +            ASSERT(outer != NO_TREC);
++
 +            // Abort the nested transaction
 +            ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 +            ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
++
 +            // As we are retrying in the lhs code, we must now try the rhs code
 +            StgTSO_trec(CurrentTSO) = outer;
              StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
              R1 = StgCatchRetryFrame_alt_code(frame);
              jump stg_ap_v_fast [R1];
          } else {
 -            // Retry in the alternative code: propagate the retry
 -            StgTSO_trec(CurrentTSO) = outer;
 +            // Retry in the rhs code: propagate the retry
              Sp = Sp + SIZEOF_StgCatchRetryFrame;
              goto retry_pop_stack;
+         }

rts/RaiseAsync.c

@@ -1043,8 +1043,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+             }
          case CATCH_STM_FRAME:
 -        case CATCH_RETRY_FRAME:
 -            // CATCH frames within an atomically block: abort the
 +            // CATCH_STM frame within an atomically block: abort the
              // inner transaction and continue.  Eventually we will
              // hit the outer transaction that will get frozen (see
              // above).
@@ -1056,14 +1055,40 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+         {
              StgTRecHeader *trec = tso -> trec;
              StgTRecHeader *outer = trec -> enclosing_trec;
 -            debugTraceCap(DEBUG_stm, cap,
 -                          "found atomically block delivering async exception");
 +            debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
              stmAbortTransaction(cap, trec);
              stmFreeAbortedTRec(cap, trec);
              tso -> trec = outer;
              break;
          };
 +        case CATCH_RETRY_FRAME:
 +            // CATCH_RETY frame within an atomically block: if we're executing
 +            // the lhs code, abort the inner transaction and continue; if we're
 +            // executing thr rhs, continue (no nested transaction to abort. See
 +            // Note [catchRetry# implementation]). Eventually we will hit the
 +            // outer transaction that will get frozen (see above).
 +            //
 +            // As for the CATCH_STM_FRAME case above, we do not care
 +            // whether the transaction is valid or not because its
 +            // possible validity cannot have caused the exception
 +            // and will not be visible after the abort.
 +        {
 +            if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
 +                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
 +                StgTRecHeader *trec = tso -> trec;
 +                StgTRecHeader *outer = trec -> enclosing_trec;
 +                stmAbortTransaction(cap, trec);
 +                stmFreeAbortedTRec(cap, trec);
 +                tso -> trec = outer;
 +            }
 +            else
 +            {
 +                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
 +            }
 +            break;
 +        };
++
          default:
              // see Note [Update async masking state on unwind] in Schedule.c
              if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {

rts/STM.c

@@ -1505,3 +1505,30 @@ void stmWriteTVar(Capability *cap,
+ }
  /*......................................................................*/
++
++
++
 +/*
++
 +Note [catchRetry# implementation]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +catchRetry# creates a nested transaction for its lhs:
 +- if the lhs transaction succeeds:
 +    - the lhs transaction is committed
 +    - its read-variables are merged with those of the parent transaction
 +    - the rhs code is ignored
 +- if the lhs transaction retries:
 +    - the lhs transaction is aborted
 +    - its read-variables are merged with those of the parent transaction
 +    - the rhs code is executed directly in the parent transaction (see #26028).
++
 +So note that:
 +- lhs code uses a nested transaction
 +- rhs code doesn't use a nested transaction
++
 +We have to take which case we're in into account (using the running_alt_code
 +field of the catchRetry frame) in catchRetry's entry code, in retry#
 +implementation, and also when an async exception is received (to cleanup the
 +right number of transactions).
++
 +*/

testsuite/tests/cpranal/sigs/T25944.hs

 +{-# LANGUAGE UndecidableInstances, LambdaCase #-}
++
 +-- | This file starts with a small reproducer for #25944 that is easy to debug
 +-- and then continues with a much larger MWE that is faithful to the original
 +-- issue.
 +module T25944 (foo, bar, popMinOneT, popMinOne) where
++
 +import Data.Functor.Identity ( Identity(..) )
 +import Data.Coerce
++
 +data ListCons a b = Nil | a :- !b
 +newtype Fix f = Fix (f (Fix f)) -- Rec
++
 +foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a)
 +foo a b = go a
 +  where
 +    -- The outer loop arranges it so that the base case `go as` of `go2` is
 +    -- bottom on the first iteration of the loop.
 +    go (Fix Nil) = Fix Nil
 +    go (Fix (a :- as)) = Fix (a :- go2 b)
 +      where
 +        go2 (Fix Nil) = go as
 +        go2 (Fix (b :- bs)) = Fix (b :- go2 bs)
++
 +bar :: Int -> (Fix (ListCons Int), Int)
 +bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property
++
 +-- Now the actual reproducer from #25944:
++
 +newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) }
++
 +cons :: Applicative m => a -> ListT m a -> ListT m a
 +cons x xs = ListT (pure (x :- xs))
++
 +nil :: Applicative m => ListT m a
 +nil = ListT (pure Nil)
++
 +instance Functor m => Functor (ListT m) where
 +  fmap f (ListT m) = ListT (go <$> m)
 +     where
 +       go Nil = Nil
 +       go (a :- m) = f a :- (f <$> m)
++
 +foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b)
 +          -> (a -> b -> c)
 +          -> c
 +          -> ListT m a -> b
 +foldListT r c n = r h . runListT
 +  where
 +    h Nil = n
 +    h (x :- ListT xs) = c x (r h xs)
 +{-# INLINE foldListT #-}
++
 +mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b
 +mapListT =
 +  foldListT
 +  ((coerce ::
 + ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) ->
 + ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b))
 +  (=<<))
 +{-# INLINE mapListT #-}
++
 +instance Monad m => Applicative (ListT m) where
 +  pure x = cons x nil
 +  {-# INLINE pure #-}
 +  liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs
 +  {-# INLINE liftA2 #-}
++
 +instance Monad m => Monad (ListT m) where
 +  xs >>= f = mapListT (flip (mapListT cons) . f) nil xs
 +  {-# INLINE (>>=) #-}
++
 +infixr 5 :<
 +data Node w a b = Leaf a | !w :< b
 +  deriving (Functor)
++
 +bimapNode f g (Leaf x) = Leaf (f x)
 +bimapNode f g (x :< xs) = x :< g xs
++
 +newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) }
++
 +-- | The 'Heap' type, specialised to the 'Identity' monad.
 +type Heap w = HeapT w Identity
++
 +instance Functor m => Functor (HeapT w m) where
 +  fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT
++
 +instance Monad m => Applicative (HeapT w m) where
 +  pure = HeapT . pure . Leaf
 +  (<*>) = liftA2 id
++
 +instance Monad m => Monad (HeapT w m) where
 +  HeapT m >>= f = HeapT (m >>= g)
 +    where
 +      g (Leaf x) = runHeapT (f x)
 +      g (w :< xs) = pure (w :< (xs >>= f))
++
 +popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a))
 +popMinOneT = go mempty [] . runHeapT
 +  where
 +    go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a))
 +    go' a Nothing = pure Nothing
 +    go' a (Just (w, HeapT xs)) = go (a <> w) [] xs
++
 +    go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a))
 +    go w a (ListT xs) = xs >>= \case
 +      Nil -> go' w (undefined)
 +      Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a)))
 +      (u :< x) :- xs -> go w ((u,x) : a) xs
 +{-# INLINE popMinOneT #-}
++
 +popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a)
 +popMinOne = runIdentity . popMinOneT
 +{-# INLINE popMinOne #-}

testsuite/tests/cpranal/sigs/T25944.stderr

++
 +==================== Cpr signatures ====================
 +T25944.$fApplicativeHeapT:
 +T25944.$fApplicativeListT:
 +T25944.$fFunctorHeapT:
 +T25944.$fFunctorListT:
 +T25944.$fFunctorNode:
 +T25944.$fMonadHeapT:
 +T25944.$fMonadListT:
 +T25944.bar: 1
 +T25944.foo:
 +T25944.popMinOne: 2(1(1,))
 +T25944.popMinOneT:
 +T25944.runHeapT:
 +T25944.runListT:
++
++

testsuite/tests/cpranal/sigs/all.T

@@ -12,3 +12,4 @@ test('T16040', normal, compile, [''])
  test('T19232', normal, compile, [''])
  test('T19398', normal, compile, [''])
  test('T19822', normal, compile, [''])
 +test('T25944', normal, compile, [''])

testsuite/tests/driver/json.stderr

-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}

+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"rendered":"json.hs:9:11: error: [GHC-48010]\n    Empty list of alternatives in case expression\n    Suggested fix:\n      Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}

testsuite/tests/driver/json_warn.stderr

 -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
 -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
 +{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n    Defined but not used: \u2018x\u2019\n","message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
 +{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n    In the use of \u2018head\u2019\n    (imported from Prelude, but defined in GHC.Internal.List):\n    \"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\"\n","message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}

testsuite/tests/lib/stm/T26028.hs

 +module Main where
++
 +import GHC.Conc
++
 +forever :: IO String
 +forever = delay 10 >> forever
++
 +terminates :: IO String
 +terminates = delay 1 >> pure "terminates"
++
 +delay s = threadDelay (1000000 * s)
++
 +async :: IO a -> IO (STM a)
 +async a = do
 +  var <- atomically (newTVar Nothing)
 +  forkIO (a >>= atomically . writeTVar var . Just)
 +  pure (readTVar var >>= maybe retry pure)
++
 +main :: IO ()
 +main = do
 +  x <- mapM async $ terminates : replicate 50000 forever
 +  r <- atomically (foldr1 orElse x)
 +  print r

testsuite/tests/lib/stm/T26028.stdout

+"terminates"

testsuite/tests/lib/stm/all.T

+test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])