Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00 Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)" This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd - - - - - 10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. - - - - - 6dfa209e by Cheng Shao at 2025-08-25T19:02:15-04:00 compiler: use zero cost coerce in hoopl setElems/mapToList This patch is a follow-up of !14680 and changes setElems/mapToList in GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel over the keys. - - - - - 04fbc92c by Ryan Scott at 2025-08-25T19:02:15-04:00 Reject infix promoted data constructors without DataKinds In the rename, make sure to apply the same `DataKinds` checks for both `HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix promoted data constructors) alike. Fixes #26318. - - - - - 13 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/Rename/HsType.hs - docs/users_guide/9.16.1-notes.rst - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - − testsuite/tests/lib/stm/T26028.hs - − testsuite/tests/lib/stm/T26028.stdout - − testsuite/tests/lib/stm/all.T - + testsuite/tests/typecheck/should_fail/T26318.hs - + testsuite/tests/typecheck/should_fail/T26318.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/Cmm/Dataflow/Label.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map) import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap +import Data.Coerce import Data.Word (Word64) @@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s {-# INLINE setElems #-} setElems :: LabelSet -> [Label] -setElems (LS s) = map mkHooplLabel (S.elems s) +setElems (LS s) = coerce $ S.elems s {-# INLINE setFromList #-} setFromList :: [Label] -> LabelSet @@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m) {-# INLINE mapToList #-} mapToList :: LabelMap b -> [(Label, b)] -mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m] +mapToList (LM m) = coerce $ M.toList m {-# INLINE mapFromList #-} mapFromList :: [(Label, v)] -> LabelMap v ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) ; this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalTyName name - ; when (isDataConName name && not (isKindName name)) $ - -- Any use of a promoted data constructor name (that is not - -- specifically exempted by isKindName) is illegal without the use - -- of DataKinds. See Note [Checking for DataKinds] in - -- GHC.Tc.Validity. - checkDataKinds env tv - ; when (isDataConName name && not (isPromoted ip)) $ - -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar. - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name) + ; checkPromotedDataConName env tv Prefix ip name ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) @@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' - ; when (isDataConName op_name && not (isPromoted prom)) $ - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + ; checkPromotedDataConName env ty Infix prom op_name ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) @@ -1670,6 +1661,30 @@ checkDataKinds env thing type_or_kind | isRnKindLevel env = KindLevel | otherwise = TypeLevel +-- | If a 'Name' is that of a promoted data constructor, perform various +-- validity checks on it. +checkPromotedDataConName :: + RnTyKiEnv -> + -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar' + -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names). + HsType GhcPs -> + -- | Whether the type is written 'Prefix' or 'Infix'. + LexicalFixity -> + -- | Whether the name was written with an explicit promotion tick or not. + PromotionFlag -> + -- | The name to check. + Name -> + TcM () +checkPromotedDataConName env ty fixity ip name + = do when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not + -- specifically exempted by isKindName) is illegal without the use + -- of DataKinds. See Note [Checking for DataKinds] in + -- GHC.Tc.Validity. + checkDataKinds env ty + when (isDataConName name && not (isPromoted ip)) $ + addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name) + warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tvb) used_names = ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release. Language ~~~~~~~~ +- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses + of promoted data constructors without enabling :extension:`DataKinds`. As a + result, you may need to enable :extension:`DataKinds` in code that did not + previously require it. + Compiler ~~~~~~~~ ===================================== rts/PrimOps.cmm ===================================== @@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, gcptr trec, outer, arg; trec = StgTSO_trec(CurrentTSO); - 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); + 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(); } } @@ -1464,26 +1453,21 @@ retry_pop_stack: outer = StgTRecHeader_enclosing_trec(trec); if (frame_type == CATCH_RETRY_FRAME) { - // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_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"); if (!StgCatchRetryFrame_running_alt_code(frame) != 0) { - // 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; + // Retry in the first branch: try the alternative + ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr"); + StgTSO_trec(CurrentTSO) = trec; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); jump stg_ap_v_fast [R1]; } else { - // Retry in the rhs code: propagate the retry + // Retry in the alternative code: propagate the retry + StgTSO_trec(CurrentTSO) = outer; Sp = Sp + SIZEOF_StgCatchRetryFrame; goto retry_pop_stack; } ===================================== rts/RaiseAsync.c ===================================== @@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, } case CATCH_STM_FRAME: - // CATCH_STM frame within an atomically block: abort the + case CATCH_RETRY_FRAME: + // CATCH frames within an atomically block: abort the // inner transaction and continue. Eventually we will // hit the outer transaction that will get frozen (see // above). @@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame"); + debugTraceCap(DEBUG_stm, cap, + "found atomically block delivering async exception"); 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,30 +1505,3 @@ 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/lib/stm/T26028.hs deleted ===================================== @@ -1,23 +0,0 @@ -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 deleted ===================================== @@ -1 +0,0 @@ -"terminates" ===================================== testsuite/tests/lib/stm/all.T deleted ===================================== @@ -1 +0,0 @@ -test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) ===================================== testsuite/tests/typecheck/should_fail/T26318.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE NoDataKinds #-} +module T26318 where + +class C1 l +instance C1 (x : xs) + +class C2 l +instance C2 (x ': xs) + +class C3 l +instance C3 ((:) x xs) + +class C4 l +instance C4 ('(:) x xs) ===================================== testsuite/tests/typecheck/should_fail/T26318.stderr ===================================== @@ -0,0 +1,20 @@ +T26318.hs:6:16: error: [GHC-68567] + Illegal type: ‘x : xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:9:16: error: [GHC-68567] + Illegal type: ‘x ': xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:12:14: error: [GHC-68567] + Illegal type: ‘(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:15:14: error: [GHC-68567] + Illegal type: ‘'(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -741,3 +741,4 @@ test('T25325', normal, compile_fail, ['']) test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) test('T26004', normal, compile_fail, ['']) +test('T26318', normal, compile_fail, ['']) ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1105,6 +1105,20 @@ class DyLD { if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) { this.rts_init(); delete this.rts_init; + + // At this point the RTS symbols in linear memory are fixed + // and constructors are run, especially the one in JSFFI.c + // that does GHC RTS initialization for any code that links + // JSFFI.o. Luckily no Haskell computation or gc has taken + // place yet, so we must set keepCAFs=1 right now! Otherwise, + // any BCO created by later TH splice or ghci expression may + // refer to any CAF that's not reachable from GC roots (here + // our only entry point is defaultServer) and the CAF could + // have been GC'ed! (#26106) + // + // We call it here instead of in RTS C code, since we only + // want keepCAFs=1 for ghci, not user code. + this.exportFuncs.setKeepCAFs(); } init(); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b69a9c35fc31b044bcac49ba80bc0fe... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b69a9c35fc31b044bcac49ba80bc0fe... You're receiving this email because of your account on gitlab.haskell.org.