Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4bc78496 by Sebastian Graf at 2025-07-24T16:19:34-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. - - - - - 0a583689 by Sylvain Henry at 2025-07-24T16:20:26-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. - - - - - deba2f40 by Simon Hengel at 2025-07-25T02:33:50-04:00 Respect `-fdiagnostics-as-json` for core diagnostics (see #24113) - - - - - a196da4c by Andrew Lelechenko at 2025-07-25T02:33:51-04:00 docs: add since pragma to Data.List.NonEmpty.mapMaybe - - - - - 15 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - libraries/base/src/Data/List/NonEmpty.hs - 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/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/Monad.hs ===================================== @@ -33,7 +33,7 @@ module GHC.Core.Opt.Monad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, msg, + putMsg, putMsgS, errorMsg, msg, diagnostic, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -41,6 +41,8 @@ module GHC.Core.Opt.Monad ( import GHC.Prelude hiding ( read ) import GHC.Driver.DynFlags +import GHC.Driver.Errors ( reportDiagnostic, reportError ) +import GHC.Driver.Config.Diagnostic ( initDiagOpts ) import GHC.Driver.Env import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) @@ -52,7 +54,6 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Error -import GHC.Utils.Error ( errorDiagnostic ) import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger import GHC.Utils.Monad @@ -383,9 +384,22 @@ putMsgS = putMsg . text putMsg :: SDoc -> CoreM () putMsg = msg MCInfo +diagnostic :: DiagnosticReason -> SDoc -> CoreM () +diagnostic reason doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc + -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg doc = msg errorDiagnostic doc +errorMsg doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportError logger name_ppr_ctx diag_opts loc doc -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Core.Make ( mkImpossibleExpr ) import GHC.Unit.Module import GHC.Unit.Module.ModGuts -import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) +import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) ) @@ -783,12 +783,11 @@ specConstrProgram guts ; let (_usg, binds', warnings) = initUs_ us $ scTopBinds env0 (mg_binds guts) - ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings) + ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings) ; return (guts { mg_binds = binds' }) } where - specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing warn_msg :: SpecFailWarnings -> SDoc warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$ text "which resulted in no specialization being generated for these functions:" $$ ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -12,7 +12,6 @@ import GHC.Prelude import GHC.Driver.DynFlags import GHC.Driver.Config -import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) @@ -55,7 +54,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Error -import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -938,10 +936,12 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs | otherwise = return () where + allCallersInlined :: Bool allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - diag_opts = initDiagOpts dflags + + doWarn :: DiagnosticReason -> CoreM () doWarn reason = - msg (mkMCDiagnostic diag_opts reason Nothing) + diagnostic reason (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) ===================================== 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) ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -449,6 +449,8 @@ filter p = List.filter p . toList -- something of type @'Maybe' b@. If this is 'Nothing', no element -- is added on to the result list. If it is @'Just' b@, then @b@ is -- included in the result list. +-- +-- @since 4.23.0.0 mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b] mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs ===================================== 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/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/c8c9416ec101e15b640f367544b07cb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8c9416ec101e15b640f367544b07cb... You're receiving this email because of your account on gitlab.haskell.org.