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 ===================================== @@ -1,3 +1,4 @@ +{-# 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: 1. 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. 3. 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 ===================================== @@ -0,0 +1,144 @@ +{ + "$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 `. + The schema can be downloaded :download:`here `. .. 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 ===================================== @@ -0,0 +1,114 @@ +{-# 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 ===================================== @@ -0,0 +1,17 @@ + +==================== 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 ===================================== @@ -1 +1 @@ -{"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 ===================================== @@ -1,2 +1,2 @@ -{"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 ===================================== @@ -0,0 +1,23 @@ +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 ===================================== @@ -0,0 +1 @@ +"terminates" ===================================== testsuite/tests/lib/stm/all.T ===================================== @@ -0,0 +1 @@ +test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f348d6432381eeb1cf782275ffb85bc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f348d6432381eeb1cf782275ffb85bc... You're receiving this email because of your account on gitlab.haskell.org.