Simon Peyton Jones pushed to branch wip/T26346 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. - - - - - 279a6fd3 by Simon Peyton Jones at 2025-08-26T17:17:15+01:00 Comments only - - - - - 40276cda by Simon Peyton Jones at 2025-08-26T17:17:42+01:00 Type-family occurs check in unification The occurs check in `GHC.Core.Unify.uVarOrFam` was inadequate in dealing with type families. Better now. See Note [The occurs check in the Core unifier]. As I did this I realised that the whole apartness thing is trickier than I thought: see (ATF13) in Note [Apartness and type families] - - - - - 17 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Tc/Utils/Unify.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_compile/T26346.hs - testsuite/tests/typecheck/should_compile/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/Core/Unify.hs ===================================== @@ -245,16 +245,21 @@ give up on), but for /substitutivity/. If we have (F x x), we can see that (F x can reduce to Double. So, it had better be the case that (F blah blah) can reduce to Double, no matter what (blah) is! -To achieve this, `go_fam` in `uVarOrFam` does this; +To achieve this, `go` in `uVarOrFam` does this; + +* We maintain /two/ substitutions, not just one: + * um_tv_env: the regular substitution, mapping TyVar :-> Type + * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application + In effect, these constitute one substitution mapping + CanEqLHS :-> Types * When we attempt to unify (G Float) ~ Int, we return MaybeApart.. - but we /also/ extend a "family substitution" [G Float :-> Int], - in `um_fam_env`, alongside the regular [tyvar :-> type] substitution in - `um_tv_env`. See the `BindMe` case of `go_fam` in `uVarOrFam`. + but we /also/ add a "family substitution" [G Float :-> Int], + to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`. * When we later encounter (G Float) ~ Bool, we apply the family substitution, very much as we apply the conventional [tyvar :-> type] substitution - when we encounter a type variable. See the `lookupFamEnv` in `go_fam` in + when we encounter a type variable. See the `lookupFamEnv` in `go` in `uVarOrFam`. So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart. Bingo. @@ -329,7 +334,7 @@ Wrinkles alternative path. So `noMatchableGivenDicts` must return False; so `mightMatchLater` must return False; so when um_bind_fam_fun returns `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See - `go_fam` in `uVarOrFam` + `go` in `uVarOrFam` (ATF6) When /matching/ can we ever have a type-family application on the LHS, in the template? You might think not, because type-class-instance and @@ -426,6 +431,26 @@ Wrinkles (ATF12) There is a horrid exception for the injectivity check. See (UR1) in in Note [Specification of unification]. +(ATF13) Consider unifying + [F a, F Int, Int] ~ [Bool, Char, a] + Working left to right you might think we would build the mapping + F a :-> Bool + F Int :-> Char + Now we discover that `a` unifies with `Int`. So really these two lists are Apart + because F Int can't be both Bool and Char. + + But that is very tricky! Perhaps whenever we unify a type variable we should + run it over the domain and (maybe range) of the type-family mapping too? + Sigh. + + For we make no such attempt. The um_fam_env has only pre-substituted types. + Fortunately, while this may make use say MaybeApart when we could say SurelyApart, + it has no effect on the correctness of unification: if we return Unifiable, it + really is Unifiable. + +(ATF14) We have to be careful about the occurs check. + See Note [The occurs check in the Core unifier] + SIDE NOTE. The paper "Closed type families with overlapping equations" http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-ex... tries to achieve the same effect with a standard yes/no unifier, by "flattening" @@ -1776,16 +1801,11 @@ uVarOrFam env ty1 ty2 kco -- E.g. a ~ F p q -- Starts with: go a (F p q) -- if `a` not bindable, swap to: go (F p q) a - go swapped substs (TyVarLHS tv1) ty2 kco - = go_tv swapped substs tv1 ty2 kco - - go swapped substs (TyFamLHS tc tys) ty2 kco - = go_fam swapped substs tc tys ty2 kco ----------------------------- - -- go_tv: LHS is a type variable + -- LHS is a type variable -- The sequence of tests is very similar to go_tv - go_tv swapped substs tv1 ty2 kco + go swapped substs lhs@(TyVarLHS tv1) ty2 kco | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1' = -- We already have a substitution for tv1 if | um_unif env -> unify_ty env ty1' ty2 kco @@ -1837,7 +1857,6 @@ uVarOrFam env ty1 ty2 kco where tv1' = umRnOccL env tv1 ty2_fvs = tyCoVarsOfType ty2 - rhs_fvs = ty2_fvs `unionVarSet` tyCoVarsOfCo kco rhs = ty2 `mkCastTy` mkSymCo kco tv1_is_bindable | not (tv1' `elemVarSet` um_foralls env) -- tv1' is not forall-bound, but tv1 can still differ @@ -1848,16 +1867,15 @@ uVarOrFam env ty1 ty2 kco | otherwise = False - occurs_check = um_unif env && - occursCheck (um_tv_env substs) tv1 rhs_fvs + occurs_check = um_unif env && uOccursCheck substs lhs rhs -- Occurs check, only when unifying -- see Note [Infinitary substitutions] - -- Make sure you include `kco` in rhs_tvs #14846 + -- Make sure you include `kco` in rhs #14846 ----------------------------- - -- go_fam: LHS is a saturated type-family application + -- LHS is a saturated type-family application -- Invariant: ty2 is not a TyVarTy - go_fam swapped substs tc1 tys1 ty2 kco + go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco -- If we are under a forall, just give up and return MaybeApart -- see (ATF3) in Note [Apartness and type families] | not (isEmptyVarSet (um_foralls env)) @@ -1883,9 +1901,10 @@ uVarOrFam env ty1 ty2 kco -- Now check if we can bind the (F tys) to the RHS -- This can happen even when matching: see (ATF7) | BindMe <- um_bind_fam_fun env tc1 tys1 rhs - = -- ToDo: do we need an occurs check here? - do { extendFamEnv tc1 tys1 rhs - ; maybeApart MARTypeFamily } + = if uOccursCheck substs lhs rhs + then maybeApart MARInfinite + else do { extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13) + ; maybeApart MARTypeFamily } -- Swap in case of (F a b) ~ (G c d e) -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e) @@ -1939,17 +1958,67 @@ uVarOrFam env ty1 ty2 kco rhs2 = mkTyConApp tc tys1 `mkCastTy` kco -occursCheck :: TvSubstEnv -> TyVar -> TyCoVarSet -> Bool -occursCheck env tv1 tvs - = anyVarSet bad tvs +uOccursCheck :: UMState -> CanEqLHS -> Type -> Bool +-- See Note [The occurs check in the Core unifier] and (ATF13) +uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty + = go emptyVarSet ty where - bad tv | Just ty <- lookupVarEnv env tv - = anyVarSet bad (tyCoVarsOfType ty) - | otherwise - = tv == tv1 + go :: TyCoVarSet -- Bound by enclosing foralls + -> Type -> Bool + go bvs ty | Just ty' <- coreView ty = go bvs ty' + go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv + = go bvs ty' + | TyVarLHS tv' <- lhs, tv==tv' + = True + | otherwise + = go bvs (tyVarKind tv) + go bvs (AppTy ty1 ty2) = go bvs ty1 || go bvs ty2 + go _ (LitTy {}) = False + go bvs (FunTy _ w arg res) = go bvs w || go bvs arg || go bvs res + go bvs (TyConApp tc tys) = go_tc bvs tc tys + + go bvs (ForAllTy (Bndr tv _) ty) + = go bvs (tyVarKind tv) || + (case lhs of + TyVarLHS tv' | tv==tv' -> False -- Shadowing + | otherwise -> go (bvs `extendVarSet` tv) ty + TyFamLHS {} -> False) -- Lookups don't happen under a forall + + go bvs (CastTy ty _co) = go bvs ty -- ToDo: should we worry about `co`? + go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`? + + go_tc bvs tc tys + | isTypeFamilyTyCon tc + , Just ty' <- lookupFamEnv fam_env tc (take arity tys) + = go bvs ty' || any (go bvs) (drop arity tys) + + | TyFamLHS tc' tys' <- lhs + , tc == tc' + , tys `lengthAtLeast` arity -- Saturated, or over-saturated + , and (zipWith tcEqType tys tys') + = True + + | otherwise + = any (go bvs) tys + where + arity = tyConArity tc -{- Note [Unifying coercion-foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [The occurs check in the Core unifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes, +so we'll get an infinite loop if we have, for example + um_tv_env: a :-> F b -- (1) + um_fam_env F b :-> a -- (2) + +So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty` +could lead to a loop. That is, could there by a type `s` such that + applySubsts( (substs + lhs:->ty), s ) is infinite + +It's vital that we do both at once: we might have (1) already and add (2); +or we might have (2) already and add (1). + +Note [Unifying coercion-foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we try to unify (forall cv. t1) ~ (forall cv. t2). See Note [ForAllTy] in GHC.Core.TyCo.Rep. ===================================== 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/Utils/Unify.hs ===================================== @@ -3342,8 +3342,9 @@ mapCheck f xs -- | Options describing how to deal with a type equality -- in the eager unifier. See 'checkTyEqRhs' data TyEqFlags m a - -- | LHS is a type family application; we are not unifying. - = TEFTyFam + = -- | TFTyFam: LHS is a type family application + -- Invariant: we are not unifying; see `notUnifying_TEFTask` + TEFTyFam { tefTyFam_occursCheck :: CheckTyEqProblem -- ^ The 'CheckTyEqProblem' to report for occurs-check failures -- (soluble or insoluble) @@ -3352,7 +3353,8 @@ data TyEqFlags m a , tef_fam_app :: TyEqFamApp m a -- ^ How to deal with type family applications } - -- | LHS is a 'TyVar'. + + -- | TEFTyVar: LHS is a 'TyVar'. | TEFTyVar -- NB: this constructor does not actually store a 'TyVar', in order to -- support being called from 'makeTypeConcrete' (which works as if we ===================================== 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_compile/T26346.hs ===================================== @@ -0,0 +1,103 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T26346 (warble) where + +import Data.Kind (Type) +import Data.Type.Equality ((:~:)(..)) + +type Nat :: Type +data Nat = Z | S Nat + +type SNat :: Nat -> Type +data SNat n where + SZ :: SNat Z + SS :: SNat n -> SNat (S n) + +type NatPlus :: Nat -> Nat -> Nat +type family NatPlus a b where + NatPlus Z b = b + NatPlus (S a) b = S (NatPlus a b) + +sNatPlus :: + forall (a :: Nat) (b :: Nat). + SNat a -> + SNat b -> + SNat (NatPlus a b) +sNatPlus SZ b = b +sNatPlus (SS a) b = SS (sNatPlus a b) + +data Bin + = Zero + | Even Bin + | Odd Bin + +type SBin :: Bin -> Type +data SBin b where + SZero :: SBin Zero + SEven :: SBin n -> SBin (Even n) + SOdd :: SBin n -> SBin (Odd n) + +type Incr :: Bin -> Bin +type family Incr b where + Incr Zero = Odd Zero -- 0 + 1 = (2*0) + 1 + Incr (Even n) = Odd n -- 2n + 1 + Incr (Odd n) = Even (Incr n) -- (2n + 1) + 1 = 2*(n + 1) + +type BinToNat :: Bin -> Nat +type family BinToNat b where + BinToNat Zero = Z + BinToNat (Even n) = NatPlus (BinToNat n) (BinToNat n) + BinToNat (Odd n) = S (NatPlus (BinToNat n) (BinToNat n)) + +sBinToNat :: + forall (b :: Bin). + SBin b -> + SNat (BinToNat b) +sBinToNat SZero = SZ +sBinToNat (SEven n) = sNatPlus (sBinToNat n) (sBinToNat n) +sBinToNat (SOdd n) = SS (sNatPlus (sBinToNat n) (sBinToNat n)) + +warble :: + forall (b :: Bin). + SBin b -> + BinToNat (Incr b) :~: S (BinToNat b) +warble SZero = Refl +warble (SEven {}) = Refl +warble (SOdd sb) | Refl <- warble sb + , Refl <- plusComm sbn (SS sbn) + = Refl + where + sbn = sBinToNat sb + + plus0R :: + forall (n :: Nat). + SNat n -> + NatPlus n Z :~: n + plus0R SZ = Refl + plus0R (SS sn) + | Refl <- plus0R sn + = Refl + + plusSnR :: + forall (n :: Nat) (m :: Nat). + SNat n -> + SNat m -> + NatPlus n (S m) :~: S (NatPlus n m) + plusSnR SZ _ = Refl + plusSnR (SS sn) sm + | Refl <- plusSnR sn sm + = Refl + + plusComm :: + forall (n :: Nat) (m :: Nat). + SNat n -> + SNat m -> + NatPlus n m :~: NatPlus m n + plusComm SZ sm + | Refl <- plus0R sm + = Refl + plusComm (SS sn) sm + | Refl <- plusComm sn sm + , Refl <- plusSnR sm sn + = Refl ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -945,3 +945,4 @@ test('T25992', normal, compile, ['']) test('T14010', normal, compile, ['']) test('T26256a', normal, compile, ['']) test('T25992a', normal, compile, ['']) +test('T26346', normal, compile, ['']) ===================================== 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/f24f9356b276205622cf05a46c81a7e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f24f9356b276205622cf05a46c81a7e... You're receiving this email because of your account on gitlab.haskell.org.