September 2025 - ghc-commits

[Git][ghc/ghc][master] Add regression test for #26056
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0959d4bc by Andreas Klebinger at 2025-09-10T10:44:12-04:00 Add regression test for #26056 - - - - - 2 changed files: - + testsuite/tests/profiling/should_compile/T26056.hs - testsuite/tests/profiling/should_compile/all.T Changes: ===================================== testsuite/tests/profiling/should_compile/T26056.hs ===================================== @@ -0,0 +1,21 @@ +module M where + +import GHC.Exts ( Any ) +import Unsafe.Coerce ( unsafeCoerce ) + +data Sigma = MkT Any + +testSubList :: Maybe Bool -> Sigma -> Sigma +testSubList (Just x) final = {-# SCC "y" #-} ( + let x' = seq x () + in case testSubList Nothing final of + MkT w -> {-# SCC "x" #-} + (unsafeCoerce MkT (konst x' myHead (unsafeCoerce w)))) +testSubList Nothing final = final + +myHead :: [a] -> a +myHead (x:_) = x + +konst :: () -> ([a] -> a) -> [a] -> a +konst _ x = x +{-# OPAQUE konst #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -20,3 +20,4 @@ test('T14931', [test_opts, unless(have_dynamic(), skip)], test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) +test('T26056', [test_opts], compile, ['-O -prof']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0959d4bcdd0a52d270e5aced2cbdf3b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0959d4bcdd0a52d270e5aced2cbdf3b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Make rationalTo{Float,Double} inline in phase 0
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 45305ab8 by sheaf at 2025-09-10T10:43:29-04:00 Make rationalTo{Float,Double} inline in phase 0 We hold off on inlining these until phase 0 to allow constant-folding rules to fire. However, once we get to phase 0, we should inline them, e.g. to expose unboxing opportunities. See CLC proposal #356. - - - - - 2 changed files: - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Float.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -4,6 +4,7 @@ * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) + * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * `GHC.Exts.IOPort#` and its related operations have been removed ([CLC #213](https://github.com/haskell/core-libraries-committee/issues/213)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -466,8 +466,8 @@ instance Fractional Float where recip x = 1.0 / x rationalToFloat :: Integer -> Integer -> Float -{-# NOINLINE [0] rationalToFloat #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToFloat #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToFloat n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -718,8 +718,8 @@ instance Fractional Double where recip x = 1.0 / x rationalToDouble :: Integer -> Integer -> Double -{-# NOINLINE [0] rationalToDouble #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToDouble #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToDouble n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -1673,7 +1673,11 @@ Now we'd have a BUILTIN constant folding rule for rationalToFloat; but to allow that rule to fire reliably we should delay inlining rationalToFloat until stage 0. (It may get an inlining from CPR analysis.) -Hence the NOINLINE[0] rationalToFloat, and similarly rationalToDouble. +Hence the INLINE[0] rationalToFloat, and similarly for rationalToDouble. +This activation means: + + - we don't inline until phase 0 (solving the above) + - we do inline starting at phase 0 (because we do want it inlining in the end) -} -- Utils View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45305ab8bc002b0e9d482e43552b4f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45305ab8bc002b0e9d482e43552b4f6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Fix a scoping error in Specialise
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b6249140 by Simon Peyton Jones at 2025-09-10T10:42:38-04:00 Fix a scoping error in Specialise This small patch fixes #26329, which triggered a scoping error. Test is in T21391, with -fpolymorphic-specialisation enabled - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1205,14 +1205,21 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1246,17 +1253,18 @@ specExpr env (Let bind body) -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | let rules = getRules (se_rules env) f , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 , (fun', args') <- collectArgs expr' - = fireRewriteRules env fun' (args'++rest_args) + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1669,10 +1677,19 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; let all_rule_bndrs = poly_qvars ++ rule_bndrs env' = env { se_subst = subst'' } -{- - ; pprTrace "spec_call" (vcat + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered , text "poly_qvars: " <+> ppr poly_qvars , text "useful: " <+> ppr useful , text "all_rule_bndrs:" <+> ppr all_rule_bndrs @@ -1681,17 +1698,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "dx_binds:" <+> ppr dx_binds , text "spec_args: " <+> ppr spec_args , text "rhs_bndrs" <+> ppr rhs_bndrs - , text "rhs_body" <+> ppr rhs_body ]) $ + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ return () -} - -- Check for (a) usefulness and (b) not already covered - -- See (SC1) in Note [Specialisations already covered] - ; let all_rules = rules_acc ++ existing_rules - -- all_rules: we look both in the rules_acc (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - ; if not useful -- No useful specialisation - || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already then return spec_acc else @@ -1702,6 +1715,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- Run the specialiser on the specialised RHS ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + -- Make the RHS of the specialised function ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b62491405ae851ae514afe18d51f0fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b62491405ae851ae514afe18d51f0fe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Report solid equality errors before custom errors
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ba210d98 by Simon Peyton Jones at 2025-09-08T16:26:36+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". See comments in `report1` in `reportWanteds` * Suppressing errors that arise from superclasses of Wanteds. See (SCE1) in Note [Suppressing confusing errors] More details in #26255. - - - - - 15 changed files: - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcType.hs - 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/UnliftedNewtypesFamilyKindFail2.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== 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, @@ -2292,6 +2292,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 @@ -2459,12 +2474,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 ===================================== @@ -1741,8 +1741,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 @@ -1801,16 +1801,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 @@ -1927,7 +1917,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 substs 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/Tc/Errors.hs ===================================== @@ -439,10 +439,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,15 +537,15 @@ 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, reportable_items) = partition suppressItem tidy_items ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items -- Now all the other constraints. We suppress errors here if -- 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 +556,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 `reportable_items`, but we + -- still want to suppress the `suppressed_items`. + ; when (null reportable_items) $ + 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 +588,42 @@ 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, custom type errors + -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint + -- + -- 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. + -- + -- But put custom type errors /before/ "non-tv eq", because if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! Also see the Assert example + -- in Note [Custom type errors in constraints] + , ("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 +633,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 +642,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 @@ -690,10 +702,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 +727,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 @@ -741,9 +759,25 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Certain errors we might encounter are potentially confusing to users. 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. +Which errors are suppressed? + +(SCE1) Superclasses of Wanteds. These are generated only 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 +820,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 +848,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-u…) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -903,75 +903,6 @@ isWantedCt = isWanted . ctEvidence isGivenCt :: Ct -> Bool isGivenCt = isGiven . ctEvidence -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType -getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred - : map getUserTypeErrorMsg (subTys pred) - where - -- Richard thinks this function is very broken. What is subTys - -- supposed to be doing? Why are exactly-saturated tyconapps special? - -- What stops this from accidentally ripping apart a call to TypeError? - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - --- | Is this an user error message type, i.e. either the form @TypeError err@ or --- @Unsatisfiable err@? -isTopLevelUserTypeError :: PredType -> Bool -isTopLevelUserTypeError pred = - isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Does this constraint contain an user error message? --- --- That is, the type is either of the form @Unsatisfiable err@, or it contains --- a type of the form @TypeError msg@, either at the top level or nested inside --- the type. -containsUserTypeError :: PredType -> Bool -containsUserTypeError pred = - isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Is this type an unsatisfiable constraint? --- If so, return the error message. -isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType -isUnsatisfiableCt_maybe t - | Just (tc, [msg]) <- splitTyConApp_maybe t - , tc `hasKey` unsatisfiableClassNameKey - = Just msg - | otherwise - = Nothing - isPendingScDict :: Ct -> Bool isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct isPendingScDict _ = False @@ -1413,6 +1344,93 @@ variable masquerading as expression holes IS treated as truly insoluble, so that it trumps other errors during error reporting. Yuk! +-} + +{- ********************************************************************* +* * + Custom type errors: Unsatisfiable and TypeError +* * +********************************************************************* -} + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + + TypeError msg -- The actual constraint is a type error + + TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + Eq (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +A good use-case is described in "Detecting the undetectable" + https://blog.csongor.co.uk/report-stuck-families/ +which features + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k +and an unsolved constraint like + Assert (TypeError ...) (F ty1) ty1 ~ ty2 +that reports that (F ty1) remains stuck. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType +getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred + : map getUserTypeErrorMsg (subTys pred) + where + -- Richard thinks this function is very broken. What is subTys + -- supposed to be doing? Why are exactly-saturated tyconapps special? + -- What stops this from accidentally ripping apart a call to TypeError? + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + +-- | Is this an user error message type, i.e. either the form @TypeError err@ or +-- @Unsatisfiable err@? +isTopLevelUserTypeError :: PredType -> Bool +isTopLevelUserTypeError pred = + isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Does this constraint contain an user error message? +-- +-- That is, the type is either of the form @Unsatisfiable err@, or it contains +-- a type of the form @TypeError msg@, either at the top level or nested inside +-- the type. +containsUserTypeError :: PredType -> Bool +containsUserTypeError pred = + isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Is this type an unsatisfiable constraint? +-- If so, return the error message. +isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType +isUnsatisfiableCt_maybe t + | Just (tc, [msg]) <- splitTyConApp_maybe t + , tc `hasKey` unsatisfiableClassNameKey + = Just msg + | otherwise + = Nothing + +{- ************************************************************************ * * Implication constraints ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -2090,6 +2090,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 {- ===================================== 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/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 ===================================== @@ -742,3 +742,5 @@ 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, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba210d981b0812aea604f884d3c0aad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba210d981b0812aea604f884d3c0aad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/9.10.3-backports] Prepare 9.10.3 final
by Zubin (＠wz1000) 10 Sep '25

10 Sep '25

Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC Commits: 3f4d7d38 by Zubin Duggal at 2025-09-10T20:00:24+05:30 Prepare 9.10.3 final - - - - - 4 changed files: - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/upload.sh - configure.ac - docs/users_guide/9.10.3-notes.rst Changes: ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -129,7 +129,7 @@ def fetch_artifacts(release: str, pipeline_id: int, for f in doc_files: subprocess.run(['tar', '-xf', f, '-C', dest]) logging.info(f'extracted docs {f} to {dest}') - index_path = destdir / 'docs' / 'index.html' + index_path = destdir / 'index.html' index_path.replace(dest / 'index.html') pdfs = list(destdir.glob('*.pdf')) for f in pdfs: ===================================== .gitlab/rel_eng/upload.sh ===================================== @@ -1,5 +1,4 @@ -#!/usr/bin/env nix-shell -#! nix-shell -i bash -p moreutils lzip zip lftp gnupg +#!/usr/bin/bash set -Eeuo pipefail @@ -41,7 +40,7 @@ set -Eeuo pipefail : ${ver:=$(ls ghc-*.tar.* | sed -ne 's/ghc-$[0-9]\+\.[0-9]\+\.[0-9]\+\(\.[0-9]\+$\?\).\+/\1/p' | head -n1)} if [ -z "$ver" ]; then echo "Failed to infer \$ver"; exit 1; fi -host="gitlab-storage.haskell.org" +host="gitlab.haskell.org:2222" usage() { echo "Usage: [rel_name=<name>] ver=7.10.3-rc2 $0 <action>" ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.10.2], [glasgow-haskell-bugs(a)haskell.org] [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.10.3], [glasgow-haskell-bugs(a)haskell.org] [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.10.2], [glasgow-ha AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the ===================================== docs/users_guide/9.10.3-notes.rst ===================================== @@ -22,9 +22,6 @@ Compiler - Fix GHC.SysTools.Ar archive member size writing logic that was emitting wrong archive member sizes in headers. (:ghc-ticket:`26120`, :ghc-ticket:`22586`) -- Fix multiple bugs in name resolution of subordinate import lists related to - type namespace specifiers and hiding clauses. (:ghc-ticket:`22581`, :ghc-ticket:`25983`, :ghc-ticket:`25984`, :ghc-ticket:`25991`) - - Use mkTrAppChecked in ds_ev_typeable to avoid false negatives for type equality involving function types. (:ghc-ticket:`25998`) @@ -40,6 +37,9 @@ Compiler - Introduce a separate argument limit for forced specs via SPEC argument with warning when limit is exceeded. (:ghc-ticket:`25197`) +- Fix compiler crash in the renamer with certain programs referencing out of + scope record fields (:ghc-ticket:`25056`) + Build system and packaging ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -79,6 +79,8 @@ WebAssembly backend Runtime system ~~~~~~~~~~~~~~ +- rts: Fix a segfault involving STM (:ghc-ticket:`26205`). + - rts: Implement WEAK EXTERNAL undef redirection by target symbol name. - rts: Handle API set symbol versioning conflicts. @@ -97,12 +99,12 @@ Runtime system ``base`` library ~~~~~~~~~~~~~~~~ -- base: Expose Backtraces constructor and fields. (:ghc-ticket:`26049`) - - base: Note strictness changes made in 4.16.0.0. (:ghc-ticket:`25886`) - Fix bugs in ``integerRecipMod`` and ``integerPowMod`` return values. (:ghc-ticket:`26017`) +- Fix incorrect results for ``naturalAndNot`` (:ghc-ticket:`26230`) + ``ghc`` library ~~~~~~~~~~~~~~~ @@ -112,9 +114,6 @@ Runtime system Build tools ~~~~~~~~~~~ -- configure: Drop probing of ld.gold since `gold` has been dropped from - binutils-2.44. (:ghc-ticket:`25716`) - - get-win32-tarballs.py: List tarball files to be downloaded if we cannot find them. (:ghc-ticket:`25929`) @@ -162,4 +161,4 @@ for further change information. libraries/transformers/transformers.cabal: Dependency of ``ghc`` library libraries/unix/unix.cabal: Dependency of ``ghc`` library libraries/Win32/Win32.cabal: Dependency of ``ghc`` library - libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable \ No newline at end of file + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f4d7d38b9661435bdde981451ac50c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f4d7d38b9661435bdde981451ac50c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-toolchain-js-no-llvm] ghc-toolchain: skip llvm program detection for unsupported targets
by Cheng Shao (＠TerrorJack) 10 Sep '25

10 Sep '25

Cheng Shao pushed to branch wip/ghc-toolchain-js-no-llvm at Glasgow Haskell Compiler / GHC Commits: 59110415 by Cheng Shao at 2025-09-10T16:28:01+02:00 ghc-toolchain: skip llvm program detection for unsupported targets This patch skips llvm program detection for wasm/js targets in ghc-toolchain; these targets are based on LLVM related toolchains like wasi-sdk/emscripten, but they don't support the LLVM backend in GHC and doesn't invoke llc/opt/llvm-as programs anyway, so we need to skip these. Otherwise in some build environments ghc-toolchain may find llc/opt/llvm-as programs for unsupported targets and configure --enable-strict-ghc-toolchain-check may fail. - - - - - 1 changed file: - utils/ghc-toolchain/exe/Main.hs Changes: ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -419,7 +419,17 @@ ldOverrideWhitelist a = OSMinGW32 -> True _ -> False - +-- | Some targets like wasm32/js are based on LLVM related toolchains +-- like wasi-sdk/emscripten, but these targets don't really support +-- the LLVM backend and doesn't invoke llc/opt/llvm-as programs +-- anyway, so we need to skip these. Otherwise in some build +-- environments ghc-toolchain may find llc/opt/llvm-as programs for +-- unsupported targets and configure +-- --enable-strict-ghc-toolchain-check may fail. +excludeNoLLVMTarget :: ArchOS -> M (Maybe a) -> M (Maybe a) +excludeNoLLVMTarget archOS m + | archOS_arch archOS `elem` [ArchWasm32, ArchJavaScript] = pure Nothing + | otherwise = m mkTarget :: Opts -> M Target mkTarget opts = do @@ -458,9 +468,9 @@ mkTarget opts = do throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" -- LLVM toolchain - llc <- optional $ findProgram "llc" (optLlc opts) ["llc"] - opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] - llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] + llc <- excludeNoLLVMTarget archOs $ optional $ findProgram "llc" (optLlc opts) ["llc"] + opt <- excludeNoLLVMTarget archOs $ optional $ findProgram "opt" (optOpt opts) ["opt"] + llvmAs <- excludeNoLLVMTarget archOs $ optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] -- Windows-specific utilities windres <- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59110415fbab937a625c640634a4186… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59110415fbab937a625c640634a4186… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ghc-toolchain-js-no-llvm
by Cheng Shao (＠TerrorJack) 10 Sep '25

10 Sep '25

Cheng Shao pushed new branch wip/ghc-toolchain-js-no-llvm at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ghc-toolchain-js-no-llvm You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26264] compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
by Zubin (＠wz1000) 10 Sep '25

10 Sep '25

Zubin pushed to branch wip/26264 at Glasgow Haskell Compiler / GHC Commits: 1e4cba38 by Zubin Duggal at 2025-09-10T18:42:28+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 - - - - - 32 changed files: - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e4cba3810df56f34a53992ee89e226… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e4cba3810df56f34a53992ee89e226… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Fix a scoping error in Specialise
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7567f51e by Simon Peyton Jones at 2025-09-10T05:31:01-04:00 Fix a scoping error in Specialise This small patch fixes #26329, which triggered a scoping error. Test is in T21391, with -fpolymorphic-specialisation enabled - - - - - f531718e by sheaf at 2025-09-10T05:31:08-04:00 Make rationalTo{Float,Double} inline in phase 0 We hold off on inlining these until phase 0 to allow constant-folding rules to fire. However, once we get to phase 0, we should inline them, e.g. to expose unboxing opportunities. See CLC proposal #356. - - - - - 500aaa99 by Andreas Klebinger at 2025-09-10T05:31:10-04:00 Add regression test for #26056 - - - - - 2eb2b028 by sheaf at 2025-09-10T05:31:15-04:00 Deep subsumption: unify mults without tcEqMult As seen in #26332, we may well end up with a non-reflexive multiplicity coercion when doing deep subsumption. We should do the same thing that we do without deep subsumption: unify the multiplicities normally, without requiring that the coercion is reflexive (which is what 'tcEqMult' was doing). Fixes #26332 - - - - - 0a5813dc by sheaf at 2025-09-10T05:31:19-04:00 lint-codes: fixup MSYS drive letter on Windows This change ensures that System.Directory.listDirectory doesn't trip up on an MSYS-style path like '/c/Foo' when trying to list all testsuite stdout/stderr files as required for testing coverage of GHC diagnostic codes in the testsuite. Fixes #25178 - - - - - d055be16 by Ben Gamari at 2025-09-10T05:31:20-04:00 gitlab-ci: Disable split sections on FreeBSD Due to #26303. - - - - - b4af59b5 by Moritz Angermann at 2025-09-10T05:31:21-04:00 Improve mach-o relocation information This change adds more information about the symbol and addresses we try to relocate in the linker. This significantly helps when deubbging relocation issues reported by users. - - - - - b7f81cd7 by Moritz Angermann at 2025-09-10T05:31:22-04:00 test.mk expect GhcLeadingUnderscore, not LeadingUnderscore (in line with the other Ghc prefixed variables. - - - - - 88c3a7ad by Moritz Angermann at 2025-09-10T05:31:23-04:00 testsuite: Fix broken exec_signals_child.c There is no signal 0. The signal mask is 1-32. - - - - - 48485986 by Moritz Angermann at 2025-09-10T05:31:24-04:00 testsuite: clarify Windows/Darwin locale rationale for skipping T6037 T2507 T8959a - - - - - 68c5cd01 by Moritz Angermann at 2025-09-10T05:31:25-04:00 Skip broken tests on macOS (due to leading underscore not handled properly in the expected output.) - - - - - 96474e13 by Zubin Duggal at 2025-09-10T05:31:25-04:00 docs(sphinx): fix links to reverse flags when using the :ghc-flag:`-fno-<flag>` syntax This solution is rather hacky and I suspect there is a better way to do this but I don't know enough about Sphinx to do better. Fixes #26352 - - - - - 18 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Tc/Utils/Unify.hs - docs/users_guide/flags.py - hadrian/src/Oracles/TestSettings.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Float.hs - linters/lint-codes/LintCodes/Coverage.hs - rts/linker/MachO.c - testsuite/ghc-config/ghc-config.hs - testsuite/tests/driver/all.T - + testsuite/tests/linear/should_compile/T26332.hs - testsuite/tests/linear/should_compile/all.T - + testsuite/tests/profiling/should_compile/T26056.hs - testsuite/tests/profiling/should_compile/all.T - testsuite/tests/rts/exec_signals_child.c - testsuite/tests/rts/linker/T11223/all.T Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1235,7 +1235,7 @@ darwin = freebsd_jobs :: [JobGroup Job] freebsd_jobs = - [ addValidateRule FreeBSDLabel (standardBuilds Amd64 FreeBSD14) + [ addValidateRule FreeBSDLabel (standardBuildsWithConfig Amd64 FreeBSD14 (splitSectionsBroken vanilla)) ] alpine_x86 :: [JobGroup Job] ===================================== .gitlab/jobs.yaml ===================================== @@ -4296,7 +4296,7 @@ "ac_cv_func_utimensat": "no" } }, - "release-x86_64-freebsd14-release": { + "release-x86_64-freebsd14-release+no_split_sections": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4307,7 +4307,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-freebsd14-release.tar.xz", + "ghc-x86_64-freebsd14-release+no_split_sections.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4349,8 +4349,8 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-freebsd14-release", - "BUILD_FLAVOUR": "release", + "BIN_DIST_NAME": "ghc-x86_64-freebsd14-release+no_split_sections", + "BUILD_FLAVOUR": "release+no_split_sections", "CABAL_INSTALL_VERSION": "3.10.3.0", "CC": "cc", "CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check", @@ -4359,7 +4359,7 @@ "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-freebsd14-release", + "TEST_ENV": "x86_64-freebsd14-release+no_split_sections", "XZ_OPT": "-9" } }, ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1205,14 +1205,21 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1246,17 +1253,18 @@ specExpr env (Let bind body) -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | let rules = getRules (se_rules env) f , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 , (fun', args') <- collectArgs expr' - = fireRewriteRules env fun' (args'++rest_args) + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1669,10 +1677,19 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; let all_rule_bndrs = poly_qvars ++ rule_bndrs env' = env { se_subst = subst'' } -{- - ; pprTrace "spec_call" (vcat + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered , text "poly_qvars: " <+> ppr poly_qvars , text "useful: " <+> ppr useful , text "all_rule_bndrs:" <+> ppr all_rule_bndrs @@ -1681,17 +1698,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "dx_binds:" <+> ppr dx_binds , text "spec_args: " <+> ppr spec_args , text "rhs_bndrs" <+> ppr rhs_bndrs - , text "rhs_body" <+> ppr rhs_body ]) $ + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ return () -} - -- Check for (a) usefulness and (b) not already covered - -- See (SC1) in Note [Specialisations already covered] - ; let all_rules = rules_acc ++ existing_rules - -- all_rules: we look both in the rules_acc (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - ; if not useful -- No useful specialisation - || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already then return spec_acc else @@ -1702,6 +1715,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- Run the specialiser on the specialised RHS ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + -- Make the RHS of the specialised function ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -1853,8 +1853,8 @@ where we eta-expanded that (:). But now foldr expects an argument with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint complains. -The easiest solution was to use tcEqMult in tc_sub_type_deep, and -insist on equality. This is only in the DeepSubsumption code anyway. +The easiest solution was to unify the multiplicities in tc_sub_type_deep, +insisting on equality. This is only in the DeepSubsumption code anyway. Note [FunTy vs non-FunTy case in tc_sub_type_deep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2047,10 +2047,7 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected -- GenSigCtxt: See Note [Setting the argument context] ; res_wrap <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res - -- See Note [Multiplicity in deep subsumption] - ; tcEqMult inst_orig act_mult exp_mult - - ; mkWpFun_FRR pos + ; mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap @@ -2058,20 +2055,32 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected where given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) --- | Like 'mkWpFun', except that it performs representation-polymorphism --- checks on the argument type. +-- | Like 'mkWpFun', except that it performs the necessary +-- representation-polymorphism checks on the argument type in the case that +-- we introduce a lambda abstraction. mkWpFun_FRR - :: Position p + :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify + -> Position p -> FunTyFlag -> Type -> TcType -> Type -- actual FunTy -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy -> HsWrapper -- ^ exp_arg ~> act_arg -> HsWrapper -- ^ act_res ~> exp_res -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy -mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap - | needs_eta - -- See Wrinkle [Representation-polymorphism checking during subtyping] - = do { (exp_arg_co, exp_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption True pos) exp_arg - ; (act_arg_co, _act_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption False pos) act_arg +mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap + = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <- + if needs_frr_checks + -- See Wrinkle [Representation-polymorphism checking during subtyping] + then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg + ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg + ; return (exp_frr_wrap, act_frr_wrap) } + else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg)) + + -- Enforce equality of multiplicities (not the more natural sub-multiplicity). + -- See Note [Multiplicity in deep subsumption] + ; act_arg_mult_co <- unify act_mult exp_mult + -- NB: don't use tcEqMult: that would require the evidence for + -- equality to be Refl, but it might well not be (#26332). + ; let exp_arg_fun_co = mkFunCo Nominal exp_af @@ -2080,7 +2089,7 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res (mkReflCo Nominal exp_res) act_arg_fun_co = mkFunCo Nominal act_af - (mkReflCo Nominal act_mult) + act_arg_mult_co act_arg_co (mkReflCo Nominal act_res) arg_wrap_frr = @@ -2090,24 +2099,16 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res -- arg_wrap :: exp_arg ~> act_arg -- arg_wrap_frr :: exp_arg_frr ~> act_arg_frr - -- NB: because of the needs_eta guard, we know that mkWpFun will - -- return (WpFun ...); so we might as well just use the WpFun constructor. ; return $ mkWpCastN exp_arg_fun_co <.> - WpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) + mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res <.> - mkWpCastN act_arg_fun_co } - | otherwise - = return $ - mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res - -- NB: because of 'needs_eta', this will never actually be a WpFun. - -- mkWpFun will turn it into a WpHole or WpCast, which is why - -- we can skip the hasFixedRuntimeRep checks in this case. - -- See Wrinkle [Representation-polymorphism checking during subtyping] + mkWpCastN act_arg_fun_co + } where - needs_eta :: Bool - needs_eta = + needs_frr_checks :: Bool + needs_frr_checks = not (hole_or_cast arg_wrap) || not (hole_or_cast res_wrap) @@ -2115,6 +2116,12 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res hole_or_cast WpHole = True hole_or_cast (WpCast {}) = True hole_or_cast _ = False + frr_ctxt :: Bool -> FixedRuntimeRepContext + frr_ctxt is_exp_ty = + FRRDeepSubsumption + { frrDSExpected = is_exp_ty + , frrDSPosition = pos + } ----------------------- deeplySkolemise :: SkolemInfo -> TcSigmaType ===================================== docs/users_guide/flags.py ===================================== @@ -236,8 +236,10 @@ class Flag(GenericFlag): reverse = self.options.get('reverse') if reverse is not None and reverse != '': # Make this also addressable via the reverse flag + # Strip leading hyphen to avoid double hyphen in anchor ID + clean_name = name[1:] if name.startswith('-') else name self.env.domaindata['std']['objects']['ghc-flag', reverse] = \ - self.env.docname, 'ghc-flag-%s' % name + self.env.docname, 'ghc-flag-%s' % clean_name # This class inherits from Sphinx's internal GenericObject, which drives # the add_object_type() utility function. We want to keep that tooling, ===================================== hadrian/src/Oracles/TestSettings.hs ===================================== @@ -73,7 +73,7 @@ testSetting key = do TestLLC -> "LLC" TestTEST_CC -> "TEST_CC" TestTEST_CC_OPTS -> "TEST_CC_OPTS" - TestLeadingUnderscore -> "LeadingUnderscore" + TestLeadingUnderscore -> "GhcLeadingUnderscore" TestGhcPackageDb -> "GhcGlobalPackageDb" TestGhcLibDir -> "GhcLibdir" ===================================== libraries/base/changelog.md ===================================== @@ -4,6 +4,7 @@ * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) + * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * `GHC.Exts.IOPort#` and its related operations have been removed ([CLC #213](https://github.com/haskell/core-libraries-committee/issues/213)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -466,8 +466,8 @@ instance Fractional Float where recip x = 1.0 / x rationalToFloat :: Integer -> Integer -> Float -{-# NOINLINE [0] rationalToFloat #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToFloat #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToFloat n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -718,8 +718,8 @@ instance Fractional Double where recip x = 1.0 / x rationalToDouble :: Integer -> Integer -> Double -{-# NOINLINE [0] rationalToDouble #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToDouble #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToDouble n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -1673,7 +1673,11 @@ Now we'd have a BUILTIN constant folding rule for rationalToFloat; but to allow that rule to fire reliably we should delay inlining rationalToFloat until stage 0. (It may get an inlining from CPR analysis.) -Hence the NOINLINE[0] rationalToFloat, and similarly rationalToDouble. +Hence the INLINE[0] rationalToFloat, and similarly for rationalToDouble. +This activation means: + + - we don't inline until phase 0 (solving the above) + - we do inline starting at phase 0 (because we do want it inlining in the end) -} -- Utils ===================================== linters/lint-codes/LintCodes/Coverage.hs ===================================== @@ -10,11 +10,13 @@ module LintCodes.Coverage -- base import Data.Char - ( isAlphaNum, isDigit, isSpace ) + ( isAlphaNum, isDigit, isSpace, toUpper ) import Data.Maybe ( mapMaybe ) import Data.List ( dropWhileEnd ) +import System.Info + ( os ) -- bytestring import qualified Data.ByteString as ByteString @@ -28,7 +30,7 @@ import qualified Data.Set as Set -- directory import System.Directory - ( doesDirectoryExist, listDirectory ) + ( doesDirectoryExist, listDirectory, makeAbsolute ) -- filepath import System.FilePath @@ -63,7 +65,12 @@ getCoveredCodes = do { top <- dropWhileEnd isSpace <$> readProcess "git" ["rev-parse", "--show-toplevel"] "" -- TODO: would be better to avoid using git entirely. - ; let testRoot = top </> "testsuite" </> "tests" + + -- When run inside an MSYS shell, git may return a Unix-style path + -- like /c/Blah. System.Directory doesn't like that, so we make sure + -- to turn that into C:/Blah. See #25178. + ; top' <- fixupMsysDrive top + ; let testRoot = top' </> "testsuite" </> "tests" ; traverseFilesFrom includeFile diagnosticCodesIn testRoot } @@ -158,3 +165,14 @@ traverseFilesFrom include_file parse_contents = go { Left _ -> mempty ; Right txt -> parse_contents txt } } } } + +-- | On Windows, change MSYS-style @/c/Blah@ to @C:/Blah@. See #25178. +fixupMsysDrive :: FilePath -> IO FilePath +fixupMsysDrive fp = do + fixedUp <- + if | os == "mingw32" || os == "win32" + , ('/':drv:'/':rest) <- fp + -> return $ toUpper drv : ':':'/':rest + | otherwise + -> return fp + makeAbsolute fixedUp ===================================== rts/linker/MachO.c ===================================== @@ -64,7 +64,7 @@ static bool fitsBits(size_t bits, int64_t value); static int64_t decodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri); static void encodeAddend(ObjectCode * oc, Section * section, - MachORelocationInfo * ri, int64_t addend); + MachORelocationInfo * ri, int64_t addend, MachOSymbol * symbol); /* Global Offset Table logic */ static bool isGotLoad(MachORelocationInfo * ri); @@ -361,15 +361,21 @@ fitsBits(size_t bits, int64_t value) { static void encodeAddend(ObjectCode * oc, Section * section, - MachORelocationInfo * ri, int64_t addend) { + MachORelocationInfo * ri, int64_t addend, MachOSymbol * symbol) { uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); + const char *symbol_name = symbol && symbol->name ? (char*)symbol->name : "<unknown>"; + const char *file_name = oc->fileName ? (char*)oc->fileName : "<unknown>"; + switch (ri->r_type) { case ARM64_RELOC_UNSIGNED: { - if(!fitsBits(8 << ri->r_length, addend)) - barf("Relocation out of range for UNSIGNED"); + if(!fitsBits(8 << ri->r_length, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation out of range for UNSIGNED in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } switch (ri->r_length) { case 0: *(uint8_t*)p = (uint8_t)addend; break; case 1: *(uint16_t*)p = (uint16_t)addend; break; @@ -382,8 +388,11 @@ encodeAddend(ObjectCode * oc, Section * section, return; } case ARM64_RELOC_SUBTRACTOR: { - if(!fitsBits(8 << ri->r_length, addend)) - barf("Relocation out of range for SUBTRACTOR"); + if(!fitsBits(8 << ri->r_length, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation out of range for SUBTRACTOR in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } switch (ri->r_length) { case 0: *(uint8_t*)p = (uint8_t)addend; break; case 1: *(uint16_t*)p = (uint16_t)addend; break; @@ -400,8 +409,11 @@ encodeAddend(ObjectCode * oc, Section * section, * do not need the last two bits of the value. If the value >> 2 * still exceeds 26bits, we won't be able to reach it. */ - if(!fitsBits(26, addend >> 2)) - barf("Relocation target for BRACH26 out of range."); + if(!fitsBits(26, addend >> 2)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for BRANCH26 out of range in %s: symbol '%s', addend 0x%llx (0x%llx >> 2), address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)(addend >> 2), (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } *p = (*p & 0xFC000000) | ((uint32_t)(addend >> 2) & 0x03FFFFFF); return; } @@ -412,8 +424,12 @@ encodeAddend(ObjectCode * oc, Section * section, * with the PAGEOFF12 relocation allows to address a relative range * of +-4GB. */ - if(!fitsBits(21, addend >> 12)) - barf("Relocation target for PAGE21 out of range."); + if(!fitsBits(21, addend >> 12)) { + const char *reloc_type = (ri->r_type == ARM64_RELOC_PAGE21) ? "PAGE21" : "GOT_LOAD_PAGE21"; + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for %s out of range in %s: symbol '%s', addend 0x%llx (0x%llx >> 12), address 0x%llx, library: %s", + reloc_type, file_name, symbol_name, (long long)addend, (long long)(addend >> 12), (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } *p = (*p & 0x9F00001F) | (uint32_t)((addend << 17) & 0x60000000) | (uint32_t)((addend >> 9) & 0x00FFFFE0); return; @@ -423,8 +439,11 @@ encodeAddend(ObjectCode * oc, Section * section, /* Store an offset into a page (4k). Depending on the instruction * the bits are stored at slightly different positions. */ - if(!fitsBits(12, addend)) - barf("Relocation target for PAGEOFF12 out or range."); + if(!fitsBits(12, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for PAGEOFF12 out of range in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } int shift = 0; if(isLoadStore(p)) { @@ -589,7 +608,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) MachOSymbol* symbol = &oc->info->macho_symbols[ri->r_symbolnum]; int64_t addend = decodeAddend(oc, section, ri); uint64_t value = symbol_value(oc, symbol); - encodeAddend(oc, section, ri, value + addend); + encodeAddend(oc, section, ri, value + addend, symbol); break; } case ARM64_RELOC_SUBTRACTOR: @@ -623,7 +642,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) // combine with addend and store int64_t addend = decodeAddend(oc, section, ri); - encodeAddend(oc, section, ri, addend - sub_value + add_value); + encodeAddend(oc, section, ri, addend - sub_value + add_value, symbol1); // skip next relocation: we've already handled it i += 1; @@ -664,7 +683,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) } } } - encodeAddend(oc, section, ri, value - pc + addend); + encodeAddend(oc, section, ri, value - pc + addend, symbol); break; } case ARM64_RELOC_PAGE21: @@ -676,7 +695,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) uint64_t pc = (uint64_t)section->start + ri->r_address; uint64_t value = (uint64_t)(isGotLoad(ri) ? symbol->got_addr : symbol->addr); ASSERT(!isGotLoad(ri) || (symbol->got_addr != 0)); - encodeAddend(oc, section, ri, ((value + addend + explicit_addend) & (-4096)) - (pc & (-4096))); + encodeAddend(oc, section, ri, ((value + addend + explicit_addend) & (-4096)) - (pc & (-4096)), symbol); // reset, just in case. explicit_addend = 0; @@ -690,7 +709,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) barf("explicit_addend and addend can't be set at the same time."); uint64_t value = (uint64_t)(isGotLoad(ri) ? symbol->got_addr : symbol->addr); ASSERT(!isGotLoad(ri) || (symbol->got_addr != 0)); - encodeAddend(oc, section, ri, 0xFFF & (value + addend + explicit_addend)); + encodeAddend(oc, section, ri, 0xFFF & (value + addend + explicit_addend), symbol); // reset, just in case. explicit_addend = 0; ===================================== testsuite/ghc-config/ghc-config.hs ===================================== @@ -43,7 +43,7 @@ main = do getGhcFieldOrDefault fields "TargetRTSLinkerOnlySupportsSharedLibs" "target RTS linker only supports shared libraries" "NO" getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO" getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO" - getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO" + getGhcFieldOrDefault fields "GhcLeadingUnderscore" "Leading underscore" "NO" getGhcFieldOrDefault fields "GhcTablesNextToCode" "Tables next to code" "NO" getGhcFieldProgWithDefault fields "AR" "ar command" "ar" getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc" ===================================== testsuite/tests/driver/all.T ===================================== @@ -179,24 +179,23 @@ test('T7060', [], makefile_test, []) test('T7130', normal, compile_fail, ['-fflul-laziness']) test('T7563', when(unregisterised(), skip), makefile_test, []) test('T6037', - # The testsuite doesn't know how to set a non-Unicode locale on Windows or MacOS < Sonoma. - # Because in previous version of MacOS the test is still broken, we mark it as fragile. + # Requires forcing a 7-bit/ASCII-only locale. + # - On Windows (mingw32) the testsuite can't reliably set a non-Unicode C locale -> expect_fail. + # - On modern Darwin there are no pure ASCII locales available -> skip. [when(opsys('mingw32'), expect_fail), - when(opsys('darwin'), fragile(24161)) + when(opsys('darwin'), skip) ], makefile_test, []) test('T2507', - # The testsuite doesn't know how to set a non-Unicode locale on Windows or MacOS < Sonoma - # Because in previous version of MacOS the test is still broken, we mark it as fragile. + # Same locale assumptions as T6037 (ASCII-only needed, unavailable on Darwin; untestable on Windows). [when(opsys('mingw32'), expect_fail), - when(opsys('darwin'), fragile(24161)) + when(opsys('darwin'), skip) ], makefile_test, []) test('T8959a', - # The testsuite doesn't know how to set a non-Unicode locale on Windows or MacOS < Sonoma - # Because in previous version of MacOS the test is still broken, we mark it as fragile. + # Same locale assumptions as T6037 (ASCII-only needed, unavailable on Darwin; untestable on Windows). [when(opsys('mingw32'), expect_fail), - when(opsys('darwin'), fragile(24161)) + when(opsys('darwin'), skip) ], makefile_test, []) ===================================== testsuite/tests/linear/should_compile/T26332.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE LinearTypes #-} + +module T26332 where + +import Unsafe.Coerce + +toLinear + :: forall a b p q. + (a %p-> b) %1-> (a %q-> b) +toLinear f = case unsafeEqualityProof @p @q of + UnsafeRefl -> f ===================================== testsuite/tests/linear/should_compile/all.T ===================================== @@ -41,6 +41,7 @@ test('T19400', unless(compiler_debugged(), skip), compile, ['']) test('T20023', normal, compile, ['']) test('T22546', normal, compile, ['']) test('T23025', normal, compile, ['-dlinear-core-lint']) +test('T26332', normal, compile, ['-O -dlinear-core-lint']) test('LinearRecUpd', normal, compile, ['']) test('T23814', normal, compile, ['']) test('LinearLet', normal, compile, ['']) ===================================== testsuite/tests/profiling/should_compile/T26056.hs ===================================== @@ -0,0 +1,21 @@ +module M where + +import GHC.Exts ( Any ) +import Unsafe.Coerce ( unsafeCoerce ) + +data Sigma = MkT Any + +testSubList :: Maybe Bool -> Sigma -> Sigma +testSubList (Just x) final = {-# SCC "y" #-} ( + let x' = seq x () + in case testSubList Nothing final of + MkT w -> {-# SCC "x" #-} + (unsafeCoerce MkT (konst x' myHead (unsafeCoerce w)))) +testSubList Nothing final = final + +myHead :: [a] -> a +myHead (x:_) = x + +konst :: () -> ([a] -> a) -> [a] -> a +konst _ x = x +{-# OPAQUE konst #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -20,3 +20,4 @@ test('T14931', [test_opts, unless(have_dynamic(), skip)], test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) +test('T26056', [test_opts], compile, ['-O -prof']) ===================================== testsuite/tests/rts/exec_signals_child.c ===================================== @@ -2,8 +2,11 @@ #include <stdio.h> #include <errno.h> -// Prints the state of the signal handlers to stdout -int main() +// Prints the state of the signal handlers to stdout. +// NOTE: We intentionally start at signal 1 (not 0). Signal number 0 is not a +// real signal; passing 0 to sigismember/sigaction is undefined behaviour and +// on Darwin was observed to yield memory corruption / junk bytes in output. +int main(void) { int open = 0, i; sigset_t blockedsigs; @@ -11,7 +14,7 @@ int main() printf("ChildInfo { masked = ["); sigprocmask(SIG_BLOCK, NULL, &blockedsigs); - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { int ret = sigismember(&blockedsigs, i); if(ret >= 0) @@ -26,7 +29,7 @@ int main() printf("], handlers = ["); open = 0; - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { struct sigaction old; if(sigaction(i, NULL, &old) >= 0) ===================================== testsuite/tests/rts/linker/T11223/all.T ===================================== @@ -33,7 +33,12 @@ test('T11223_simple_duplicate', test('T11223_simple_duplicate_lib', [extra_files(['bar.c', 'foo.c', 'foo.hs']), - when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg), + when(ghc_dynamic(), skip), + # Darwin/Mach-O reports external C symbols with a leading underscore (e.g. _a, _c) + # which our expected stderr (shared with ELF platforms) does not account for. + # Rather than broaden normalisation here, skip on darwin for now. + when(opsys('darwin'), skip), + normalise_errmsg_fun(normalise_duplicate_errmsg), req_c], makefile_test, ['t_11223_simple_duplicate_lib']) @@ -57,7 +62,10 @@ test('T11223_link_order_b_a_succeed', test('T11223_link_order_a_b_2_fail', [extra_files(['bar.c', 'foo.c', 'foo3.hs']), - when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg), + when(ghc_dynamic(), skip), + # See note above about Mach-O leading underscores; skip on darwin. + when(opsys('darwin'), skip), + normalise_errmsg_fun(normalise_duplicate_errmsg), req_c], makefile_test, ['t_11223_link_order_a_b_2_fail']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0be4dca51133ca2f91841804e27672… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0be4dca51133ca2f91841804e27672… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26315] Add a test case for #26396
by Simon Peyton Jones (＠simonpj) 10 Sep '25

10 Sep '25

Simon Peyton Jones pushed to branch wip/T26315 at Glasgow Haskell Compiler / GHC Commits: 643d10bc by Simon Peyton Jones at 2025-09-10T08:46:08+01:00 Add a test case for #26396 ...same bug ast #26315 - - - - - 2 changed files: - + testsuite/tests/deriving/should_compile/T26396.hs - testsuite/tests/deriving/should_compile/all.T Changes: ===================================== testsuite/tests/deriving/should_compile/T26396.hs ===================================== @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} + +module T26396 where + +import Data.Kind +import Data.Type.Equality +import GHC.TypeNats + +newtype Vector (el :: Type) (len :: Natural) = Vector [el] + deriving (Eq) + +data Sized (f :: Natural -> Type) where + Sized :: KnownNat len => f len -> Sized f + +instance (forall (len :: Natural). Eq (f len)) => Eq (Sized f) where + Sized xs == Sized ys = case sameNat xs ys of + Nothing -> False + Just Refl -> xs == ys + +newtype Foo (el :: Type) = Foo (Sized (Vector el)) + deriving (Eq) ===================================== testsuite/tests/deriving/should_compile/all.T ===================================== @@ -154,3 +154,4 @@ test('T24955b', normal, compile, ['']) test('T24955c', normal, compile, ['']) test('T25148c', normal, compile, ['']) test('deriving-inferred-ty-arg', normal, compile, ['-ddump-deriv -dsuppress-uniques']) +test('T26396', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/643d10bc437e8f2218129b007b659cf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/643d10bc437e8f2218129b007b659cf… You're receiving this email because of your account on gitlab.haskell.org.

1 0