Simon Peyton Jones pushed to branch wip/T26255 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. - - - - - bedc1004 by Cheng Shao at 2025-08-26T09:31:18-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. - - - - - 13250d97 by Ryan Scott at 2025-08-26T09:31:59-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. - - - - - ca1b9bea by Simon Peyton Jones at 2025-08-26T17:30:29+01:00 Report solid equality errors before custom errors This MR fixes #26255 by reporting solid equality errors like Int ~ Bool before "custom type errors". Details in #26255, and the comments with `report1` in the patch. The priority for custom type errors was introduced in the original custom-type-error patch, and has (sadly) been present since GHC 9.4 Better position for custom errors Prioritise errors with a (F tys ~ rigid) See the ticket for more Further improvements * Suppress all Wanted superclass constraints * Priorities (F tys ~ rigid) over custom type errors Wibble comments More wibbles Wibble - - - - - 26 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Utils/TcType.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/T18851.hs - + testsuite/tests/typecheck/should_fail/T26255a.hs - + testsuite/tests/typecheck/should_fail/T26255a.stderr - + testsuite/tests/typecheck/should_fail/T26255b.hs - + testsuite/tests/typecheck/should_fail/T26255b.stderr - + testsuite/tests/typecheck/should_fail/T26255c.hs - + testsuite/tests/typecheck/should_fail/T26255c.stderr - + testsuite/tests/typecheck/should_fail/T26318.hs - + testsuite/tests/typecheck/should_fail/T26318.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.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/Core/Type.hs ===================================== @@ -132,7 +132,7 @@ module GHC.Core.Type ( kindBoxedRepLevity_maybe, mightBeLiftedType, mightBeUnliftedType, definitelyLiftedType, definitelyUnliftedType, - isAlgType, isDataFamilyAppType, + isAlgType, isDataFamilyApp, isSatTyFamApp, isPrimitiveType, isStrictType, isTerminatingType, isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, @@ -2295,6 +2295,21 @@ isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this +-- | Check whether a type is a data family type +isDataFamilyApp :: Type -> Bool +isDataFamilyApp ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +isSatTyFamApp :: Type -> Maybe (TyCon, [Type]) +-- Return the argument if we have a saturated type family application +-- Why saturated? See (ATF4) in Note [Apartness and type families] +isSatTyFamApp (TyConApp tc tys) + | isTypeFamilyTyCon tc + && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated + = Just (tc, tys) +isSatTyFamApp _ = Nothing + buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon -- This function is here because here is where we have @@ -2462,12 +2477,6 @@ isAlgType ty isAlgTyCon tc _other -> False --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. -- Currently, it's just 'isUnliftedType'. ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -1690,8 +1690,8 @@ unify_ty env ty1 ty2 kco where mb_tc_app1 = splitTyConApp_maybe ty1 mb_tc_app2 = splitTyConApp_maybe ty2 - mb_sat_fam_app1 = isSatFamApp ty1 - mb_sat_fam_app2 = isSatFamApp ty2 + mb_sat_fam_app1 = isSatTyFamApp ty1 + mb_sat_fam_app2 = isSatTyFamApp ty2 unify_ty _ _ _ _ = surelyApart @@ -1750,16 +1750,6 @@ unify_tys env orig_xs orig_ys -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] ---------------------------------- -isSatFamApp :: Type -> Maybe (TyCon, [Type]) --- Return the argument if we have a saturated type family application --- Why saturated? See (ATF4) in Note [Apartness and type families] -isSatFamApp (TyConApp tc tys) - | isTypeFamilyTyCon tc - && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated - = Just (tc, tys) -isSatFamApp _ = Nothing - --------------------------------- uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM () -- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy @@ -1876,7 +1866,7 @@ uVarOrFam env ty1 ty2 kco | otherwise -> maybeApart MARTypeFamily -- Check for equality F tys1 ~ F tys2 - | Just (tc2, tys2) <- isSatFamApp ty2 + | Just (tc2, tys2) <- isSatTyFamApp ty2 , tc1 == tc2 = go_fam_fam tc1 tys1 tys2 kco ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -363,7 +363,7 @@ pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) is_closed_or_data_family :: Type -> Bool - is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty -- For efficiency, represent both lists as difference lists. -- comb performs the concatenation, for both lists. ===================================== 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 = ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error +import GHC.Types.Unique( hasKey ) +import GHC.Builtin.Names( errorMessageTypeErrorFamKey ) import qualified GHC.Types.Unique.Map as UM import GHC.Unit.Module @@ -439,10 +441,9 @@ reportBadTelescope _ _ skol_info skols -- See Note [Constraints to ignore]. ignoreConstraint :: Ct -> Bool ignoreConstraint ct - | AssocFamPatOrigin <- ctOrigin ct - = True - | otherwise - = False + = case ctOrigin ct of + AssocFamPatOrigin -> True -- See (CIG1) + _ -> False -- | Makes an error item from a constraint, calculating whether or not -- the item should be suppressed. See Note [Wanteds rewrite Wanteds] @@ -538,7 +539,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs -- See Note [Suppressing confusing errors] - ; let (suppressed_items, items0) = partition suppress tidy_items + ; let (suppressed_items, items0) = partition suppressItem tidy_items ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 @@ -546,7 +547,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- any of the first batch failed, or if the enclosing context -- says to suppress ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1 + ; (_, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" @@ -557,12 +558,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) - -- Only now, if there are no errors, do we report suppressed ones - -- See Note [Suppressing confusing errors] - -- We don't need to update the context further because of the - -- whenNoErrs guard - ; whenNoErrs $ - do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items + -- If there are no other errors to report, report suppressed errors. + -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors + -- we might have reported warnings only from `items0`, but we still want to + -- suppress the `suppressed_items`. + ; when (null items0) $ + do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) + suppressed_items + -- ctxt_for_insols: the suppressed errors can be Int~Bool, which + -- will have made the incoming `ctxt` be True; don't make that suppress + -- the Int~Bool error! ; massertPpr (null more_leftovers) (ppr more_leftovers) } } where env = cec_tidy ctxt @@ -585,29 +590,49 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics DE_Multiplicity mult_co loc -> (es1, es2, es3, (mult_co, loc):es4) - -- See Note [Suppressing confusing errors] - suppress :: ErrorItem -> Bool - suppress item - | Wanted <- ei_flavour item - = is_ww_fundep_item item - | otherwise - = False - -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree -- It's crucial that anything that is considered insoluble -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later - report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - -- (Handles TypeError and Unsatisfiable) + report1 = [ -- We put implicit lifting errors first, because are solid errors + -- See "Implicit lifting" in GHC.Tc.Gen.Splice + -- Note [Lifecycle of an untyped splice, and PendingRnSplice] + ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) - , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) + -- Next, solid equality errors , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("skolem eq1", very_wrong, True, mkSkolReporter) , ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr) , ("skolem eq2", skolem_eq, True, mkSkolReporter) + + -- Next, family applications like (F t1 t2 ~ rigid_ty) + -- These could be solved by doing a type-family reduction for F + -- which probably means fixing a unfication variable in t1/t2 + -- See discussion in #26255, where F had an injectivity annotation, + -- and we had [W] F alpha ~ "foo" + -- The real error is that the "foo" should be "bar", because there is + -- type instance F Int = "bar" + -- We could additionally filter on the injectivty annotation, + -- but currently we don't. + , ("fam app", is_fam_app_eq, True, mkGroupReporter mkEqErr) + + -- Put custom type errors after solid equality errors. In #26255 we + -- had a custom error (T <= F alpha) which was suppressing a far more + -- informative (K Int ~ [K alpha]). That mismatch between K and [] is + -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence + -- perhaps be able to solve T <= F alpha, by reducing F Int. + -- + -- Custom errors should precede "non-tv eq", becuase if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! + , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) + + -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar , ("non-tv eq", non_tv_eq, True, mkSkolReporter) -- The only remaining equalities are alpha ~ ty, @@ -617,6 +642,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + ] -- report2: we suppress these if there are insolubles elsewhere in the tree @@ -625,11 +651,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] - -- report3: suppressed errors should be reported as categorized by either report1 - -- or report2. Keep this in sync with the suppress function above - report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr) - ] - -- rigid_nom_eq, rigid_nom_tv_eq, is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool @@ -650,6 +671,13 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- Representation-polymorphism errors, to be reported using mkFRRErr. is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item + -- Things like (F t1 t2 ~N Maybe s) + -- But only proper type families; not (TypeError t1 t2 ~N blah) + is_fam_app_eq _ (EqPred NomEq ty1 ty2) + | Just (tc,_) <- isSatTyFamApp ty1 + = not (tc `hasKey` errorMessageTypeErrorFamKey) && isRigidTy ty2 + is_fam_app_eq _ _ = False + -- Things like (a ~N b) or (a ~N F Bool) skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 skolem_eq _ _ = False @@ -690,10 +718,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics is_qc _ (ForAllPred {}) = True is_qc _ _ = False - -- See situation (1) of Note [Suppressing confusing errors] - is_ww_fundep item _ = is_ww_fundep_item item - is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin - given_eq_spec -- See Note [Given errors] | has_gadt_match_here = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) @@ -719,6 +743,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics = has_gadt_match implics --------------- +suppressItem :: ErrorItem -> Bool + -- See Note [Suppressing confusing errors] +suppressItem item + | Wanted <- ei_flavour item + , let orig = errorItemOrigin item + = isWantedSuperclassOrigin orig -- See (SCE1) + || isWantedWantedFunDepOrigin orig -- See (SCE2) + | otherwise + = False + isSkolemTy :: TcLevel -> Type -> Bool -- The type is a skolem tyvar isSkolemTy tc_lvl ty @@ -743,7 +777,23 @@ If there are any other errors to report, at all, we want to suppress these. Which errors (only 1 case right now): -1) Errors which arise from the interaction of two Wanted fun-dep constraints. +(SCE1) Superclasses of Wanteds. These are generated on in case they trigger functional + dependencies. If such a constraint is unsolved, then its "parent" constraint must + also be unsolved, and is much more informative to the user. Example (#26255): + class (MinVersion <= F era) => Era era where { ... } + f :: forall era. EraFamily era -> IO () + f = ..blah... -- [W] Era era + Here we have simply omitted "Era era =>" from f's type. But we'll end up with + /two/ Wanted constraints: + [W] d1 : Era era + [W] d2 : MinVersion <= F era -- Superclass of d1 + We definitely want to report d1 and not d2! Happily it's easy to filter out those + superclass-Wanteds, becuase their Origin betrays them. + + See test T18851 for an example of how it is (just, barely) possible for the /only/ + errors to be superclass-of-Wanted constraints. + +(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints. Example: class C a b | a -> b where @@ -786,7 +836,7 @@ they will remain unfilled, and might have been used to rewrite another constrain Currently, the constraints to ignore are: -1) Constraints generated in order to unify associated type instance parameters +(CIG1) Constraints generated in order to unify associated type instance parameters with class parameters. Here are two illustrative examples: class C (a :: k) where @@ -814,6 +864,9 @@ Currently, the constraints to ignore are: If there is any trouble, checkValidFamInst bleats, aborting compilation. +(Note: Aug 25: this seems a rather tricky corner; + c.f. Note [Suppressing confusing errors]) + Note [Implementation of Unsatisfiable constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-un...). ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -2059,6 +2059,7 @@ isRigidTy ty | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal | Just {} <- tcSplitAppTy_maybe ty = True | isForAllTy ty = True + | Just {} <- isLitTy ty = True | otherwise = False {- ===================================== 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/T18851.hs ===================================== @@ -33,3 +33,14 @@ f = show (undefined :: c) -- blows up at run time once type checks g :: String g = f @A @B + +{- +[W] Show c, Num int, C int A, C int B, C int c +Superclasses + C_FD int ~ A + C_FD int ~ B + C_FD int ~ c +--> + C_FD int ~ B + B ~ A +-} ===================================== testsuite/tests/typecheck/should_fail/T26255a.hs ===================================== @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255a where + +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + , KnownSymbol (EraName era) + ) => + Era era + where + type EraName era = (r :: Symbol) | r -> era + + type ProtVerLow era :: Nat + + eraName :: Proxy era -> String + eraName _ = symbolVal (Proxy :: Proxy (EraName era)) + +data FooEra + +instance Era FooEra where + type EraName FooEra = "Foo" + type ProtVerLow FooEra = 1 + +data BarEra + +instance Era BarEra where + type EraName BarEra = "Bar" + type ProtVerLow BarEra = 2 + +fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era +fromEraName _ = Proxy + +noCompileErrorMessage :: IO () +noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar") + +brokenCompileErrorMessage1 :: IO () +brokenCompileErrorMessage1 = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah") + ===================================== testsuite/tests/typecheck/should_fail/T26255a.stderr ===================================== @@ -0,0 +1,10 @@ +T26255a.hs:46:51: error: [GHC-18872] + • Couldn't match type ‘EraName era0’ with ‘"Blah"’ + arising from a use of ‘fromEraName’ + The type variable ‘era0’ is ambiguous + • In the second argument of ‘($)’, namely + ‘fromEraName (Proxy :: Proxy "Blah")’ + In the second argument of ‘($)’, namely + ‘eraName $ fromEraName (Proxy :: Proxy "Blah")’ + In the expression: + putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah") ===================================== testsuite/tests/typecheck/should_fail/T26255b.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255b where + +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + , KnownSymbol (EraName era) + ) => + Era era + where + type EraName era = (r :: Symbol) | r -> era + + type ProtVerLow era :: Nat + + eraName :: Proxy era -> String + eraName _ = symbolVal (Proxy :: Proxy (EraName era)) + +data FooEra + +instance Era FooEra where + type EraName FooEra = "Foo" + type ProtVerLow FooEra = 1 + +data BarEra + +instance Era BarEra where + type EraName BarEra = "Bar" + type ProtVerLow BarEra = 2 + +fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era +fromEraName _ = Proxy + +noCompileErrorMessage :: IO () +noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar") + +brokenCompileErrorMessage2 :: IO () +brokenCompileErrorMessage2 = putStrLn $ eraName $ head $ fromEraName (Proxy :: Proxy "Bar") ===================================== testsuite/tests/typecheck/should_fail/T26255b.stderr ===================================== @@ -0,0 +1,9 @@ +T26255b.hs:46:58: error: [GHC-83865] + • Couldn't match expected type: [Proxy era0] + with actual type: Proxy BarEra + • In the second argument of ‘($)’, namely + ‘fromEraName (Proxy :: Proxy "Bar")’ + In the second argument of ‘($)’, namely + ‘head $ fromEraName (Proxy :: Proxy "Bar")’ + In the second argument of ‘($)’, namely + ‘eraName $ head $ fromEraName (Proxy :: Proxy "Bar")’ ===================================== testsuite/tests/typecheck/should_fail/T26255c.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255c where + +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + ) => + Era era + where + type ProtVerLow era :: Nat + +newtype EraFamily era = EraFamily Int + +class Era era => NewEra era where + eraFamilySize :: EraFamily era -> Int + +printEraFamilySize :: EraFamily era -> IO () +printEraFamilySize = print . eraFamilySize ===================================== testsuite/tests/typecheck/should_fail/T26255c.stderr ===================================== @@ -0,0 +1,11 @@ +T26255c.hs:30:30: error: [GHC-39999] + • No instance for ‘NewEra era’ + arising from a use of ‘eraFamilySize’ + Possible fix: + add (NewEra era) to the context of + the type signature for: + printEraFamilySize :: forall {k} (era :: k). EraFamily era -> IO () + • In the second argument of ‘(.)’, namely ‘eraFamilySize’ + In the expression: print . eraFamilySize + In an equation for ‘printEraFamilySize’: + printEraFamilySize = print . eraFamilySize ===================================== 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/UnliftedNewtypesFamilyKindFail2.stderr ===================================== @@ -1,3 +1,7 @@ +UnliftedNewtypesFamilyKindFail2.hs:12:1: error: [GHC-83865] + • Expected a type, but ‘F 5’ has kind ‘5’ + • In the newtype family instance declaration for ‘F’ + UnliftedNewtypesFamilyKindFail2.hs:12:20: error: [GHC-83865] • Expected a type, but ‘5’ has kind ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -741,3 +741,6 @@ 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, ['']) +test('T26255a', normal, compile_fail, ['']) +test('T26255b', 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/7477a4ab24e6727634a129a031a29f7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7477a4ab24e6727634a129a031a29f7... You're receiving this email because of your account on gitlab.haskell.org.