April 2025 - ghc-commits

[Git][ghc/ghc] Pushed new tag ghc-9.10.2-rc1
by Ben Gamari (＠bgamari) 18 Apr '25

18 Apr '25

Ben Gamari pushed new tag ghc-9.10.2-rc1 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/ghc-9.10.2-rc1 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][ghc-9.10] 2 commits: rel-eng: Fix mktemp usage in recompress-all
by Ben Gamari (＠bgamari) 18 Apr '25

18 Apr '25

Ben Gamari pushed to branch ghc-9.10 at Glasgow Haskell Compiler / GHC Commits: 429b1e0d by Ben Gamari at 2025-04-18T12:38:01-04:00 rel-eng: Fix mktemp usage in recompress-all We need a temporary directory, not a file. (cherry picked from commit 914eb49a0637ef12c3f7db71c9da93c05389497b) - - - - - 88d3b9e6 by Ben Gamari at 2025-04-18T17:02:33-04:00 Finalize release notes - - - - - 3 changed files: - .gitlab/rel_eng/recompress-all - docs/users_guide/9.10.2-notes.rst - docs/users_guide/release-notes.rst Changes: ===================================== .gitlab/rel_eng/recompress-all ===================================== @@ -21,7 +21,7 @@ usage : %.zip : %.tar.xz echo "[tarxz->zip] $< to $@..." - tmp="$$(mktemp tmp.XXX)" && \ + tmp="$$(mktemp -d tmp.XXX)" && \ tar -C "$$tmp" -xf $< && \ cd "$$tmp" && \ zip -9 -r ../$@ * && \ ===================================== docs/users_guide/9.10.2-notes.rst ===================================== @@ -1,4 +1,4 @@ -.. _release-9-10-1: +.. _release-9-10-2: Version 9.10.2 ============== @@ -7,10 +7,6 @@ following sections. See the `migration guide <https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.10>`_ on the GHC Wiki for specific guidance on migrating programs to this release. -Language -~~~~~~~~ - - Compiler ~~~~~~~~ @@ -183,16 +179,6 @@ Build system and packaging - Fixed a bug where building ghc from source using ghc-9.8.4 failed with an error mentioning ``ghc_unique_counter64``. (:ghc-ticket:`25576`) -``base`` library -~~~~~~~~~~~~~~~~ - - - - -``ghc-prim`` library -~~~~~~~~~~~~~~~~~~~~ - - ``ghc`` library ~~~~~~~~~~~~~~~ @@ -210,10 +196,6 @@ Build system and packaging * The library is now versioned according to the ghc version it shipped with. -``template-haskell`` library -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Included libraries ~~~~~~~~~~~~~~~~~~ ===================================== docs/users_guide/release-notes.rst ===================================== @@ -5,3 +5,4 @@ Release notes :maxdepth: 1 9.10.1-notes + 9.10.2-notes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0cdf476d3878ede6f5cf26a2226e87… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0cdf476d3878ede6f5cf26a2226e87… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Refactor Handling of Multiple Default Declarations
by Marge Bot (＠marge-bot) 18 Apr '25

18 Apr '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00 Refactor Handling of Multiple Default Declarations Fixes: #25912, #25914, #25934 Previously, GHC discarded all loaded defaults (tcg_default) when local defaults were encountered during typechecking. According to the exportable-named-default proposal (sections 2.4.2 and 2.4.3), local defaults should be merged into tcg_default, retaining any defaults already present while overriding where necessary. Key Changes: * Introduce DefaultProvenance to track the origin of default declarations (local, imported, or built-in), replacing the original cd_module in ClassDefaults with cd_provenance :: DefaultProvenance. * Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only converting renamed class defaults into ClassDefaults. * Add extendDefaultEnvWithLocalDefaults to merge local defaults into the environment, with proper duplication checks: - Duplicate local defaults for a class trigger an error. - Local defaults override imported or built-in defaults. * Update and add related notes: Note [Builtin class defaults], Note [DefaultProvenance]. * Add regression tests: T25912, T25914, T25934. Thanks sam and simon for the help on this patch. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00 template-haskell: Remove `addrToByteArrayName` and `addrToByteArray` These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. Resolves #24782 - - - - - df16b34f by Sylvain Henry at 2025-04-18T15:46:00-04:00 RTS: remove target info and fix host info (#24058) The RTS isn't a compiler, hence it doesn't have a target and we remove the reported target info displayed by "+RTS --info". We also fix the host info displayed by "+RTS --info": the host of the RTS is the RTS-building compiler's target, not the compiler's host (wrong when doing cross-compilation). - - - - - 6227d6aa by Sylvain Henry at 2025-04-18T15:46:00-04:00 RTS: remove build info As per the discussion in !13967, there is no reason to tag the RTS with information about the build platform. - - - - - 9c42eba1 by Vladislav Zavialov at 2025-04-18T15:46:01-04:00 Diagnostics: remove the KindMismatch constructor (#25957) The KindMismatch constructor was only used as an intermediate representation in pretty-printing. Its removal addresses a problem detected by the "codes" test case: [GHC-89223] is untested (constructor = KindMismatch) In a concious deviation from the usual procedure, the error code GHC-89223 is removed entirely rather than marked as Outdated. The reason is that it never was user-facing in the first place. - - - - - 27 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - configure.ac - hadrian/src/Settings/Packages.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/changelog.md - rts/RtsUtils.c - testsuite/ghc-config/ghc-config.hs - + testsuite/tests/default/T25912.hs - + testsuite/tests/default/T25912.stdout - + testsuite/tests/default/T25912_helper.hs - + testsuite/tests/default/T25914.hs - + testsuite/tests/default/T25934.hs - testsuite/tests/default/all.T - testsuite/tests/default/default-fail03.stderr - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod58.stderr Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -236,6 +236,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile +import GHC.Platform.ArchOS import GHC.Unit.Types import GHC.Unit.Parser @@ -3455,6 +3456,9 @@ compilerInfo dflags ("Build platform", cBuildPlatformString), ("Host platform", cHostPlatformString), ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("target os string", stringEncodeOS (platformOS (targetPlatform dflags))), + ("target arch string", stringEncodeArch (platformArch (targetPlatform dflags))), + ("target word size in bits", show (platformWordSizeInBits (targetPlatform dflags))), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), ("Have native code generator", showBool $ platformNcgSupported platform), ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv ) +import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info @@ -1333,7 +1333,7 @@ tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name ; let warn = fmap fromIfaceWarningTxt iface_warn ; return ClassDefaults { cd_class = cls , cd_types = tys' - , cd_module = Just this_mod + , cd_provenance = DP_Imported this_mod , cd_warn = warn } } where tyThingConClass :: TyThing -> Class ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -85,7 +85,7 @@ import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Types.TH import GHC.Tc.Utils.TcType -import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_module)) +import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..)) import GHC.Types.Error import GHC.Types.Error.Codes import GHC.Types.Hint @@ -582,11 +582,19 @@ instance Diagnostic TcRnMessage where TcRnMultipleDefaultDeclarations cls dup_things -> mkSimpleDecorated $ hang (text "Multiple default declarations for class" <+> quotes (ppr cls)) - 2 (vcat (map pp dup_things)) + 2 (pp dup_things) where - pp :: LDefaultDecl GhcRn -> SDoc - pp (L locn DefaultDecl {}) - = text "here was another default declaration" <+> ppr (locA locn) + pp :: ClassDefaults -> SDoc + pp (ClassDefaults { cd_provenance = prov }) + = case prov of + DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 } + -> let + what = + if isH98 + then text "default declaration" + else text "named default declaration" + in text "conflicting" <+> what <+> text "at:" <+> ppr loc + _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults TcRnBadDefaultType ty deflt_clss -> mkSimpleDecorated $ hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") @@ -4388,21 +4396,6 @@ pprMismatchMsg ctxt conc :: [String] -> String conc = unwords . filter (not . null) -pprMismatchMsg _ - (KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act }) - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | isConstraintLikeKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - pprMismatchMsg ctxt (TypeEqMismatch { teq_mismatch_item = item , teq_mismatch_ty1 = ty1 -- These types are the actual types @@ -4421,11 +4414,11 @@ pprMismatchMsg ctxt | Just nargs_msg <- num_args_msg , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = nargs_msg $$ pprMismatchMsg ctxt ea_msg + = nargs_msg $$ ea_msg | ea_looks_same ty1 ty2 exp act , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = pprMismatchMsg ctxt ea_msg + = ea_msg | otherwise = bale_out_msg @@ -4437,7 +4430,7 @@ pprMismatchMsg ctxt Left ea_info -> pprMismatchMsg ctxt mismatch_err : map (pprExpectedActualInfo ctxt) ea_info Right ea_err -> [ pprMismatchMsg ctxt mismatch_err - , pprMismatchMsg ctxt ea_err ] + , ea_err ] mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 -- 'expected' is (TYPE rep) or (CONSTRAINT rep) @@ -4534,7 +4527,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) Left infos -> vcat (map (pprExpectedActualInfo ctxt) infos) Right other_msg - -> pprMismatchMsg ctxt other_msg + -> other_msg where main_msg | null useful_givens @@ -4569,6 +4562,18 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) [wanted] -> quotes (ppr wanted) _ -> pprTheta wanteds +pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc +pprKindMismatchMsg thing exp act + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | isConstraintLikeKind exp = text "a constraint" + | Just arg <- kindRep_maybe exp -- TYPE t0 + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) -- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) -- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. @@ -4863,7 +4868,7 @@ pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = supplementary = case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos - Right msg -> pprMismatchMsg ctxt msg + Right msg -> msg pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic }) @@ -5094,8 +5099,6 @@ mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type) mismatchMsg_ExpectedActuals = \case BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> Just (exp, act) - KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } -> - Just (exp, act) TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> Just (exp,act) CouldNotDeduce { cnd_extra = cnd_extra } @@ -5421,7 +5424,7 @@ skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan **********************************************************************-} mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg + -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] SDoc mk_supplementary_ea_msg ctxt level ty1 ty2 orig | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig , not (ea_looks_same ty1 ty2 exp act) @@ -5444,7 +5447,7 @@ ea_looks_same ty1 ty2 exp act -- (TYPE 'LiftedRep) and Type both print the same way. mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind - -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg + -> CtOrigin -> Either [ExpectedActualInfo] SDoc -- Constructs a "Couldn't match" message -- The (Maybe ErrorItem) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) @@ -5452,13 +5455,11 @@ mk_ea_msg ctxt at_top level (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) | Just thing <- mb_thing , KindLevel <- level - = Right $ KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act } + = Right $ pprKindMismatchMsg thing exp act | Just item <- at_top , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing mismatch = mkBasicMismatchMsg ea item exp act - = Right mismatch + = Right (pprMismatchMsg ctxt mismatch) | otherwise = Left $ if expanded_syns @@ -7139,7 +7140,7 @@ pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs = -------------------------------------------------------------------------------- defaultTypesAndImport :: ClassDefaults -> SDoc -defaultTypesAndImport ClassDefaults{cd_types, cd_module = Just cdm} = +defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} = hang (parens $ pprWithCommas ppr cd_types) 2 (text "imported from" <+> ppr cdm) defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types) ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -1504,7 +1504,7 @@ data TcRnMessage where Text cases: module/mod58 -} - TcRnMultipleDefaultDeclarations :: Class -> [LDefaultDecl GhcRn] -> TcRnMessage + TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports more than one default declaration for the same class, and they are not all @@ -5690,19 +5690,9 @@ data MismatchMsg , mismatch_mb_same_occ :: Maybe SameOccInfo } - -- | A type has an unexpected kind. - -- - -- Test cases: T2994, T7609, ... - | KindMismatch - { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? - , kmismatch_expected :: Type - , kmismatch_actual :: Type - } - -- TODO: combine with 'BasicMismatch'. - -- | A mismatch between two types, which arose from a type equality. -- - -- Test cases: T1470, tcfail212. + -- Test cases: T1470, tcfail212, T2994, T7609. | TypeEqMismatch { teq_mismatch_item :: ErrorItem , teq_mismatch_ty1 :: Type ===================================== compiler/GHC/Tc/Gen/Default.hs ===================================== @@ -5,9 +5,10 @@ -} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} -- | Typechecking @default@ declarations -module GHC.Tc.Gen.Default ( tcDefaults ) where +module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where import GHC.Prelude import GHC.Hs @@ -16,7 +17,7 @@ import GHC.Builtin.Names import GHC.Core.Class import GHC.Core.Predicate ( Pred (..), classifyPredType ) -import GHC.Data.Maybe ( firstJusts ) +import GHC.Data.Maybe ( firstJusts, maybeToList ) import GHC.Tc.Errors.Types import GHC.Tc.Gen.HsType @@ -30,20 +31,17 @@ import GHC.Tc.Utils.TcMType ( newWanted ) import GHC.Tc.Utils.TcType import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv ) +import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) ) import GHC.Types.SrcLoc -import GHC.Unit.Types (Module, ghcInternalUnit, moduleUnit) +import GHC.Unit.Types (ghcInternalUnit, moduleUnit) -import GHC.Utils.Misc (fstOf3, sndOf3) import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt -import Data.Function (on) -import Data.List.NonEmpty ( NonEmpty (..), groupBy ) +import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) import Data.Traversable ( for ) {- Note [Named default declarations] @@ -86,7 +84,7 @@ The moving parts are as follows: * The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default` field of `TcGblEnv`. -* This field is populated by `GHC.Tc.Gen.Default.tcDefaults` which typechecks +* This field is populated by `GHC.Tc.Gen.Default.tcDefaultDecls` which typechecks any local or imported `default` declarations. * Only a single default declaration can be in effect in any single module for @@ -103,7 +101,7 @@ The moving parts are as follows: in effect be `default Num (Integer, Double)` as specified by Haskell Language Report. - See Note [Default class defaults] in GHC.Tc.Utils.Env + See Note [Builtin class defaults] in GHC.Tc.Utils.Env * Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings` extensions also affect the traditional `default` declarations that don't name @@ -120,61 +118,54 @@ The moving parts are as follows: tracked separately from `ImportAvails`, and returned separately from them by `GHC.Rename.Names.rnImports`. -* Class defaults are exported explicitly, as the example above shows. A module's - exported defaults are tracked in `tcg_default_exports`, which are then - transferred to `mg_defaults`, `md_defaults`, and `mi_defaults_`. +* Class defaults are exported explicitly. + For example, + module M( ..., default C, ... ) + exports the defaults for class C. + + A module's exported defaults are computed by exports_from_avail, + tracked in tcg_default_exports, which are then transferred to mg_defaults, + md_defaults, and mi_defaults_. + + Only defaults explicitly exported are actually exported. + (i.e. No defaults are exported in a module header like: + module M where ...) + See Note [Default exports] in GHC.Tc.Gen.Export * Since the class defaults merely help the solver infer the correct types, they leave no trace in Haskell Core. -} --- See Note [Named default declarations] -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM DefaultEnv -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults decls - = do { tcg_env <- getGblEnv - ; let - here = tcg_mod tcg_env - is_internal_unit = moduleUnit here == ghcInternalUnit - ; case (is_internal_unit, decls) of - -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place - -- in the module. - -- We shortcut the treatment of such a default declaration with no class nor types: we won't - -- try to point 'cd_class' to 'Num' since it may not even exist yet. - { (True, [L _ (DefaultDecl _ Nothing [])]) - -> return $ defaultEnv [] - -- Otherwise we take apart the declaration into the class constructor and its default types. - ; _ -> - do { h2010_dflt_clss <- getH2010DefaultClasses - ; decls' <- mapMaybeM (declarationParts h2010_dflt_clss) decls - ; let - -- Find duplicate default declarations - decl_tag (mb_cls, _, _) = - case mb_cls of - Nothing -> Nothing - Just cls -> if cls `elem` h2010_dflt_clss - then Nothing - else Just cls - decl_groups = groupBy ((==) `on` decl_tag) decls' - ; decls_without_dups <- mapM (reportDuplicates here h2010_dflt_clss) decl_groups - ; return $ defaultEnv (concat decls_without_dups) - } } } +-- | Typecheck a collection of default declarations. These can be either: +-- +-- - Haskell 98 default declarations, of the form @default (Float, Double)@ +-- - Named default declarations, of the form @default Cls(Int, Char)@. +-- See Note [Named default declarations] +tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] +tcDefaultDecls decls = + do + tcg_env <- getGblEnv + let here = tcg_mod tcg_env + is_internal_unit = moduleUnit here == ghcInternalUnit + case (is_internal_unit, decls) of + -- No default declarations + (_, []) -> return [] + -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults], + -- some modules in ghc-internal include an empty `default ()` declaration, in order + -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`), + -- but we must still make sure not to error if we fail to look up e.g. the 'Num' + -- typeclass when typechecking such a default declaration. To do this, we wrap + -- calls of 'tcLookupClass' in 'tryTc'. + (True, [L _ (DefaultDecl _ Nothing [])]) -> do + h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames + case NE.nonEmpty h2010_dflt_clss of + Nothing -> return [] + Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls + -- Otherwise we take apart the declaration into the class constructor and its default types. + _ -> do + h2010_dflt_clss <- getH2010DefaultClasses + toClassDefaults h2010_dflt_clss decls where getH2010DefaultClasses :: TcM (NonEmpty Class) -- All the classes subject to defaulting with a Haskell 2010 default @@ -186,18 +177,18 @@ tcDefaults decls -- No extensions: Num -- OverloadedStrings: add IsString -- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable - getH2010DefaultClasses - = do { num_cls <- tcLookupClass numClassName - ; ovl_str <- xoptM LangExt.OverloadedStrings + getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames + getH2010DefaultNames + = do { ovl_str <- xoptM LangExt.OverloadedStrings ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let extra_clss = deflt_str ++ deflt_interactive - ; return $ num_cls :| extra_clss + ; let deflt_str = if ovl_str + then [isStringClassName] + else [] + ; let deflt_interactive = if ext_deflt + then interactiveClassNames + else [] + ; let extra_clss_names = deflt_str ++ deflt_interactive + ; return $ numClassName :| extra_clss_names } declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type])) declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys)) @@ -220,20 +211,49 @@ tcDefaults decls ; return (Just cls, decl, tau_tys) } } - reportDuplicates :: Module -> NonEmpty Class -> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [Type]) -> TcM [ClassDefaults] - reportDuplicates here h2010_dflt_clss ((mb_cls, _, tys) :| []) - = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing } - | c <- case mb_cls of - Nothing -> NE.toList h2010_dflt_clss - Just cls -> [cls] - ] - -- Report an error on multiple default declarations for the same class in the same module. - -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module - reportDuplicates _ (num_cls :| _) decls@((_, L locn _, _) :| _) - = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (sndOf3 <$> decls)) - >> pure [] + toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] + toClassDefaults h2010_dflt_clss dfs = do + dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs + return $ concatMap (go False) dfs where - cls = fromMaybe num_cls $ firstJusts (fmap fstOf3 decls) + go h98 = \case + (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss] + (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)] + +-- | Extend the default environment with the local default declarations +-- and do the action in the extended environment. +extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a +extendDefaultEnvWithLocalDefaults decls action = do + tcg_env <- getGblEnv + let default_env = tcg_default tcg_env + new_default_env <- insertDefaultDecls default_env decls + updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action + +-- | Insert local default declarations into the default environment. +-- +-- See 'insertDefaultDecl'. +insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv +insertDefaultDecls = foldrM insertDefaultDecl +-- | Insert a local default declaration into the default environment. +-- +-- If the class already has a local default declaration in the DefaultEnv, +-- report an error and return the original DefaultEnv. Otherwise, override +-- any existing default declarations (e.g. imported default declarations). +-- +-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module +insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv +insertDefaultDecl (L decl_loc new_cls_defaults ) default_env = + case lookupDefaultEnv default_env (className cls) of + Just cls_defaults + | DP_Local {} <- cd_provenance cls_defaults + -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults) + ; return default_env } + _ -> return $ insertDefaultEnv new_cls_defaults default_env + -- NB: this overrides imported and built-in default declarations + -- for this class, if there were any. + where + cls = cd_class new_cls_defaults + -- | Check that the type is an instance of at least one of the default classes. -- @@ -289,10 +309,6 @@ simplifyDefault cls dflt_ty@(L l _) -> Nothing } -dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage -dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things) - = TcRnMultipleDefaultDeclarations cls dup_things - {- Note [Instance check for default declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see a named default declaration, such as: @@ -327,4 +343,4 @@ whether each type is an instance of: - ... or the IsString class, with -XOverloadedStrings - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes, with -XExtendedDefaultRules --} \ No newline at end of file +-} ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -282,7 +282,7 @@ example, would import the above `default IsString (Text, String)` declaration into the importing module. -The `cd_module` field of `ClassDefaults` tracks the module whence the default was +The `cd_provenance` field of `ClassDefaults` tracks the module whence the default was imported from, for the purpose of warning reports. The said warning report may be triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to the default export. In the latter case the warning text is stored in the ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -383,6 +383,7 @@ the actual contents of the module are wired in to GHC. -} {- Note [Disambiguation of multiple default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Named default declarations] in GHC.Tc.Gen.Default @@ -1811,9 +1812,8 @@ tcTyClsInstDecls tycl_decls deriv_decls default_decls binds -- -- But only after we've typechecked 'default' declarations. -- See Note [Typechecking default declarations] - defaults <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = defaults }) $ do { - + defaults <- tcDefaultDecls default_decls + ; extendDefaultEnvWithLocalDefaults defaults $ do { -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -128,8 +128,7 @@ import GHC.Types.SourceFile import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..), - defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv ) +import GHC.Types.DefaultEnv import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) @@ -971,21 +970,28 @@ isBrackStage _other = False ************************************************************************ -} -{- Note [Default class defaults] +{- Note [Builtin class defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In absence of user-defined `default` declarations, the set of class defaults in -effect (i.e. `DefaultEnv`) is determined by the absence or -presence of the `ExtendedDefaultRules` and `OverloadedStrings` extensions. In their -absence, the only rule in effect is `default Num (Integer, Double)` as specified by -Haskell Language Report. - -In GHC's internal packages `DefaultEnv` is empty to minimize cross-module dependencies: -the `Num` class or `Integer` type may not even be available in low-level modules. If -you don't do this, attempted defaulting in package ghc-prim causes an actual crash -(attempting to look up the `Integer` type). - -A user-defined `default` declaration overrides the defaults for the specified class, -and only for that class. +In the absence of user-defined `default` declarations, the set of class defaults in +effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and +`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect +is `default Num (Integer, Double)`, as specified by the Haskell 2010 report. + +Remark [No built-in defaults in ghc-internal] + + When typechecking the ghc-internal package, we **do not** include any built-in + defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may + not even be available (they haven't been typechecked yet). + +Remark [default () in ghc-internal] + + Historically, modules inside ghc-internal have used a single default declaration, + of the form `default ()`, to work around the problem described in + Remark [No built-in defaults in ghc-internal]. + + When we typecheck such a default declaration, we must also make sure not to fail + if e.g. 'Num' is not in scope. We thus have special treatment for this case, + in 'GHC.Tc.Gen.Default.tcDefaultDecls'. -} tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types @@ -997,7 +1003,7 @@ tcGetDefaultTys -- See also #1974 builtinDefaults cls tys = ClassDefaults{ cd_class = cls , cd_types = tys - , cd_module = Nothing + , cd_provenance = DP_Builtin , cd_warn = Nothing } -- see Note [Named default declarations] in GHC.Tc.Gen.Default @@ -1005,7 +1011,8 @@ tcGetDefaultTys ; this_module <- tcg_mod <$> getGblEnv ; let this_unit = moduleUnit this_module ; if this_unit == ghcInternalUnit - -- see Note [Default class defaults] + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env then return (defaults, extended_defaults) else do -- not one of the built-in units @@ -1037,6 +1044,8 @@ tcGetDefaultTys } -- The Num class is already user-defaulted, no need to construct the builtin default _ -> pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults + -- override them. ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ] ; return (deflt_tys, extended_defaults) } } ===================================== compiler/GHC/Types/DefaultEnv.hs ===================================== @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} module GHC.Types.DefaultEnv ( ClassDefaults (..) + , DefaultProvenance (..) , DefaultEnv , emptyDefaultEnv , isEmptyDefaultEnv @@ -12,6 +14,8 @@ module GHC.Types.DefaultEnv , defaultList , plusDefaultEnv , mkDefaultEnv + , insertDefaultEnv + , isHaskell2010Default ) where @@ -22,6 +26,7 @@ import GHC.Tc.Utils.TcType (Type) import GHC.Types.Name (Name, nameUnique, stableNameCmp) import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly) +import GHC.Types.SrcLoc (SrcSpan) import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module) import GHC.Utils.Outputable @@ -37,13 +42,73 @@ import Data.Function (on) -- NB: this includes Haskell98 default declarations, at the 'Num' key. type DefaultEnv = NameEnv ClassDefaults +{- Note [DefaultProvenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each `ClassDefault` is annotated with its `DefaultProvenance`, which +says where the default came from. Specifically +* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module + being compiled, at location `loc`, and the boolean `h98` indicates whether + it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`). +* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`. +* `DP_Builtin`: the default was automatically provided by GHC. + see Note [Builtin class defaults] in GHC.Tc.Utils.Env + +These annotations are used to disambiguate multiple defaults for the same class. +For example, consider the following modules: + + module M( default C ) where { default C( ... ) } + module M2( default C) where { import M } + module N( default C () where { default C(... ) } + + module A where { import M2 } + module B where { import M2; import N } + module A1 where { import N; default C ( ... ) } + module B2 where { default C ( ... ); default C ( ... ) } + +When compiling N, the default for C is annotated with DP_Local loc. +When compiling M2, the default for C is annotated with DP_Local M. +When compiling A, the default for C is annotated with DP_Imported M2. + +Cases we needed to disambiguate: + * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N. + * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc. + * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2. + +For how we disambiguate these cases, +See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module. +-} + +-- | The provenance of a collection of default types for a class. +-- see Note [DefaultProvenance] for more details +data DefaultProvenance + -- | A locally defined default declaration. + = DP_Local + { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration + , defaultDeclH98 :: Bool -- ^ Is this a Haskell 98 default declaration? + } + -- | Built-in class defaults. + | DP_Builtin + -- | Imported class defaults. + | DP_Imported Module -- ^ The module from which the defaults were imported + deriving (Eq, Data) + +instance Outputable DefaultProvenance where + ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty) + ppr DP_Builtin = text "built-in" + ppr (DP_Imported mod) = ppr mod + +isHaskell2010Default :: DefaultProvenance -> Bool +isHaskell2010Default = \case + DP_Local { defaultDeclH98 = isH98 } -> isH98 + DP_Builtin -> True + DP_Imported {} -> False + -- | Defaulting type assignments for the given class. data ClassDefaults = ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined , cd_types :: [Type] - , cd_module :: Maybe Module - -- ^ @Nothing@ for built-in, - -- @Just@ the current module or the module whence the default was imported + , cd_provenance :: DefaultProvenance + -- ^ Where the defaults came from -- see Note [Default exports] in GHC.Tc.Gen.Export , cd_warn :: Maybe (WarningTxt GhcRn) -- ^ Warning emitted when the default is used @@ -70,6 +135,9 @@ defaultList :: DefaultEnv -> [ClassDefaults] defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts -- sortBy recovers determinism +insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv +insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d + lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults lookupDefaultEnv env = lookupUFM_Directly env . nameUnique ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -420,7 +420,6 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "MultiplicityCoercionsNotSupported" = 59840 -- Type mismatch errors GhcDiagnosticCode "BasicMismatch" = 18872 - GhcDiagnosticCode "KindMismatch" = 89223 GhcDiagnosticCode "TypeEqMismatch" = 83865 GhcDiagnosticCode "CouldNotDeduce" = 05617 ===================================== configure.ac ===================================== @@ -265,8 +265,8 @@ dnl we ask the bootstrapping compiler what platform it is for if test "${WithGhc}" != "" then - bootstrap_host=`"${WithGhc}" +RTS --info | grep '^ ,("Host platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` - bootstrap_target=`"${WithGhc}" +RTS --info | grep '^ ,("Target platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` + bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` + bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` if test "$bootstrap_host" != "$bootstrap_target" then echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work" ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -286,10 +286,6 @@ ghcInternalArgs = package ghcInternal ? do rtsPackageArgs :: Args rtsPackageArgs = package rts ? do projectVersion <- getSetting ProjectVersion - hostPlatform <- queryHost targetPlatformTriple - hostArch <- queryHost queryArch - hostOs <- queryHost queryOS - hostVendor <- queryHost queryVendor buildPlatform <- queryBuild targetPlatformTriple buildArch <- queryBuild queryArch buildOs <- queryBuild queryOS @@ -371,18 +367,16 @@ rtsPackageArgs = package rts ? do , input "**/RtsUtils.c" ? pure [ "-DProjectVersion=" ++ show projectVersion - , "-DHostPlatform=" ++ show hostPlatform - , "-DHostArch=" ++ show hostArch - , "-DHostOS=" ++ show hostOs - , "-DHostVendor=" ++ show hostVendor + -- the RTS' host is the compiler's target (the target should be + -- per stage ideally...) + , "-DHostPlatform=" ++ show targetPlatform + , "-DHostArch=" ++ show targetArch + , "-DHostOS=" ++ show targetOs + , "-DHostVendor=" ++ show targetVendor , "-DBuildPlatform=" ++ show buildPlatform , "-DBuildArch=" ++ show buildArch , "-DBuildOS=" ++ show buildOs , "-DBuildVendor=" ++ show buildVendor - , "-DTargetPlatform=" ++ show targetPlatform - , "-DTargetArch=" ++ show targetArch - , "-DTargetOS=" ++ show targetOs - , "-DTargetVendor=" ++ show targetVendor , "-DGhcUnregisterised=" ++ show (yesNo ghcUnreg) , "-DTablesNextToCode=" ++ show (yesNo ghcEnableTNC) , "-DRtsWay=\"rts_" ++ show way ++ "\"" ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -1,6 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE UnboxedTuples #-} module Language.Haskell.TH.Syntax ( @@ -190,16 +190,11 @@ module Language.Haskell.TH.Syntax ( nothingName, rightName, trueName, - addrToByteArrayName, - addrToByteArray, ) where -import Data.Array.Byte import GHC.Boot.TH.Lift import GHC.Boot.TH.Syntax -import GHC.Exts -import GHC.ST import System.FilePath -- This module completely re-exports 'GHC.Boot.TH.Syntax', @@ -211,17 +206,3 @@ makeRelativeToProject fp | isRelative fp = do root <- getPackageRoot return (root </> fp) makeRelativeToProject fp = return fp - --- The following two defintions are copied from 'Data.Byte.Array' --- in order to preserve the old export list of 'TH.Syntax'. --- They will soon be removed as part of #24782. - -addrToByteArrayName :: Name -addrToByteArrayName = 'addrToByteArray - -addrToByteArray :: Int -> Addr# -> ByteArray -addrToByteArray (I# len) addr = runST $ ST $ - \s -> case newByteArray# len s of - (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of - s'' -> case unsafeFreezeByteArray# mb s'' of - (# s''', ret #) -> (# s''', ByteArray ret #) ===================================== libraries/template-haskell/changelog.md ===================================== @@ -13,6 +13,8 @@ * Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals. Users should use `Language.Haskell.TH.Lib` instead, which exposes a stable version of this API. + + * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. ## 2.23.0.0 ===================================== rts/RtsUtils.c ===================================== @@ -364,18 +364,10 @@ void printRtsInfo(const RtsConfig rts_config) { printf(" [(\"GHC RTS\", \"YES\")\n"); mkRtsInfoPair("GHC version", ProjectVersion); mkRtsInfoPair("RTS way", RtsWay); - mkRtsInfoPair("Build platform", BuildPlatform); - mkRtsInfoPair("Build architecture", BuildArch); - mkRtsInfoPair("Build OS", BuildOS); - mkRtsInfoPair("Build vendor", BuildVendor); mkRtsInfoPair("Host platform", HostPlatform); mkRtsInfoPair("Host architecture", HostArch); mkRtsInfoPair("Host OS", HostOS); mkRtsInfoPair("Host vendor", HostVendor); - mkRtsInfoPair("Target platform", TargetPlatform); - mkRtsInfoPair("Target architecture", TargetArch); - mkRtsInfoPair("Target OS", TargetOS); - mkRtsInfoPair("Target vendor", TargetVendor); mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS)); // TODO(@Ericson2314) This is a joint property of the RTS and generated // code. The compiler will soon be multi-target so it doesn't make sense to ===================================== testsuite/ghc-config/ghc-config.hs ===================================== @@ -1,6 +1,7 @@ import System.Environment import System.Process import Data.Maybe +import Control.Monad main :: IO () main = do @@ -9,15 +10,25 @@ main = do info <- readProcess ghc ["+RTS", "--info"] "" let fields = read info :: [(String,String)] getGhcFieldOrFail fields "HostOS" "Host OS" - getGhcFieldOrFail fields "WORDSIZE" "Word size" - getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" - getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" - getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" getGhcFieldOrFail fields "RTSWay" "RTS way" + -- support for old GHCs (pre 9.13): infer target platform by querying the rts... + let query_rts = isJust (lookup "Target platform" fields) + when query_rts $ do + getGhcFieldOrFail fields "WORDSIZE" "Word size" + getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" + getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" + getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" + info <- readProcess ghc ["--info"] "" let fields = read info :: [(String,String)] + unless query_rts $ do + getGhcFieldOrFail fields "WORDSIZE" "target word size in bits" + getGhcFieldOrFail fields "TARGETPLATFORM" "target platform string" + getGhcFieldOrFail fields "TargetOS_CPP" "target os string" + getGhcFieldOrFail fields "TargetARCH_CPP" "target arch string" + getGhcFieldOrFail fields "GhcStage" "Stage" getGhcFieldOrFail fields "GhcDebugAssertions" "Debug on" getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator" ===================================== testsuite/tests/default/T25912.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE NamedDefaults #-} + +module Main where + +import T25912_helper + +-- now we declare the default instances +-- for the classes C again to check that +-- it won't hide the default instances for class B +default C (String) + +main :: IO () +main = do + print b ===================================== testsuite/tests/default/T25912.stdout ===================================== @@ -0,0 +1 @@ +"String" ===================================== testsuite/tests/default/T25912_helper.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE NamedDefaults #-} + +module T25912_helper ( default C, C(c), default B, b ) where + +class C a where + c :: a +instance C Int where + c = 1 +instance C String where + c = "String" +default C (String) + +class B a where + b :: a +instance B String where + b = "String" +default B (String) ===================================== testsuite/tests/default/T25914.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedDefaults, OverloadedStrings #-} +module NamedDefaultsNum where +import Data.String +default Num () +foo = "abc" ===================================== testsuite/tests/default/T25934.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE NamedDefaults #-} +module T25934 where +default Num (Int) +default Show (Int) ===================================== testsuite/tests/default/all.T ===================================== @@ -39,3 +39,6 @@ test('T25858v2', [extra_files(['T25858v2_helper.hs'])], multimod_compile_and_run test('T25858v3', [extra_files(['T25858v3_helper.hs'])], multimod_compile_and_run, ['T25858v3', '']) test('T25858v4', normal, compile_and_run, ['']) test('T25882', normal, compile, ['']) +test('T25912', [extra_files(['T25912_helper.hs'])], multimod_compile_and_run, ['T25912', '']) +test('T25914', normal, compile, ['']) +test('T25934', normal, compile, ['']) ===================================== testsuite/tests/default/default-fail03.stderr ===================================== @@ -1,3 +1,4 @@ -default-fail03.hs:4:1: [GHC-99565] +default-fail03.hs:4:1: error: [GHC-99565] Multiple default declarations for class ‘Num’ - here was another default declaration default-fail03.hs:3:1-29 + conflicting named default declaration at: default-fail03.hs:3:1-29 + ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -46,7 +46,6 @@ [GHC-06200] is untested (constructor = BlockedEquality) [GHC-81325] is untested (constructor = ExpectingMoreArguments) [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt) -[GHC-89223] is untested (constructor = KindMismatch) [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan) [GHC-95822] is untested (constructor = TcRnSimplifierTooManyIterations) [GHC-17268] is untested (constructor = TcRnCharLiteralOutOfRange) ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1369,7 +1369,7 @@ module Language.Haskell.TH.Quote where quoteFile :: QuasiQuoter -> QuasiQuoter module Language.Haskell.TH.Syntax where - -- Safety: Trustworthy + -- Safety: Safe type AnnLookup :: * data AnnLookup = AnnLookupModule Module | AnnLookupName Name type AnnTarget :: * @@ -1780,8 +1780,6 @@ module Language.Haskell.TH.Syntax where addModFinalizer :: Q () -> Q () addTempFile :: GHC.Internal.Base.String -> Q GHC.Internal.IO.FilePath addTopDecls :: [Dec] -> Q () - addrToByteArray :: GHC.Internal.Types.Int -> GHC.Internal.Prim.Addr# -> Data.Array.Byte.ByteArray - addrToByteArrayName :: Name badIO :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a bindCode :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> (a -> Code m b) -> Code m b bindCode_ :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> Code m b -> Code m b ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -8,7 +8,7 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-boun ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1216:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0] ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc] ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices] ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice] @@ -18,10 +18,8 @@ ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation] -ref compiler/GHC/Tc/Gen/Default.hs:87:6: Note [Disambiguation of multiple default declarations] -ref compiler/GHC/Tc/Gen/Default.hs:193:11: Note [Disambiguation of multiple default declarations] ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2693:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration] ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures] @@ -30,8 +28,6 @@ ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice] ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Module.hs:385:3: Note [Disambiguation of multiple default declarations] -ref compiler/GHC/Tc/Module.hs:420:7: Note [Disambiguation of multiple default declarations] ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting] ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics] ===================================== testsuite/tests/module/mod58.stderr ===================================== @@ -1,4 +1,4 @@ - mod58.hs:4:1: error: [GHC-99565] Multiple default declarations for class ‘Num’ - here was another default declaration mod58.hs:3:1-21 + conflicting default declaration at: mod58.hs:3:1-21 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e7df7747c0359264c63a282112cb5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e7df7747c0359264c63a282112cb5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/no-kind-mismatch] Diagnostics: remove the KindMismatch constructor (#25957)
by Vladislav Zavialov (＠int-index) 18 Apr '25

18 Apr '25

Vladislav Zavialov pushed to branch wip/int-index/no-kind-mismatch at Glasgow Haskell Compiler / GHC Commits: 926464f1 by Vladislav Zavialov at 2025-04-18T19:56:44+03:00 Diagnostics: remove the KindMismatch constructor (#25957) The KindMismatch constructor was only used as an intermediate representation in pretty-printing. Its removal addresses a problem detected by the "codes" test case: [GHC-89223] is untested (constructor = KindMismatch) In a concious deviation from the usual procedure, the error code GHC-89223 is removed entirely rather than marked as Outdated. The reason is that it never was user-facing in the first place. - - - - - 4 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - testsuite/tests/diagnostic-codes/codes.stdout Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -4396,21 +4396,6 @@ pprMismatchMsg ctxt conc :: [String] -> String conc = unwords . filter (not . null) -pprMismatchMsg _ - (KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act }) - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | isConstraintLikeKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - pprMismatchMsg ctxt (TypeEqMismatch { teq_mismatch_item = item , teq_mismatch_ty1 = ty1 -- These types are the actual types @@ -4429,11 +4414,11 @@ pprMismatchMsg ctxt | Just nargs_msg <- num_args_msg , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = nargs_msg $$ pprMismatchMsg ctxt ea_msg + = nargs_msg $$ ea_msg | ea_looks_same ty1 ty2 exp act , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = pprMismatchMsg ctxt ea_msg + = ea_msg | otherwise = bale_out_msg @@ -4445,7 +4430,7 @@ pprMismatchMsg ctxt Left ea_info -> pprMismatchMsg ctxt mismatch_err : map (pprExpectedActualInfo ctxt) ea_info Right ea_err -> [ pprMismatchMsg ctxt mismatch_err - , pprMismatchMsg ctxt ea_err ] + , ea_err ] mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 -- 'expected' is (TYPE rep) or (CONSTRAINT rep) @@ -4542,7 +4527,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) Left infos -> vcat (map (pprExpectedActualInfo ctxt) infos) Right other_msg - -> pprMismatchMsg ctxt other_msg + -> other_msg where main_msg | null useful_givens @@ -4577,6 +4562,18 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) [wanted] -> quotes (ppr wanted) _ -> pprTheta wanteds +pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc +pprKindMismatchMsg thing exp act + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | isConstraintLikeKind exp = text "a constraint" + | Just arg <- kindRep_maybe exp -- TYPE t0 + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) -- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) -- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. @@ -4871,7 +4868,7 @@ pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = supplementary = case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos - Right msg -> pprMismatchMsg ctxt msg + Right msg -> msg pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic }) @@ -5102,8 +5099,6 @@ mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type) mismatchMsg_ExpectedActuals = \case BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> Just (exp, act) - KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } -> - Just (exp, act) TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> Just (exp,act) CouldNotDeduce { cnd_extra = cnd_extra } @@ -5429,7 +5424,7 @@ skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan **********************************************************************-} mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg + -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] SDoc mk_supplementary_ea_msg ctxt level ty1 ty2 orig | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig , not (ea_looks_same ty1 ty2 exp act) @@ -5452,7 +5447,7 @@ ea_looks_same ty1 ty2 exp act -- (TYPE 'LiftedRep) and Type both print the same way. mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind - -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg + -> CtOrigin -> Either [ExpectedActualInfo] SDoc -- Constructs a "Couldn't match" message -- The (Maybe ErrorItem) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) @@ -5460,13 +5455,11 @@ mk_ea_msg ctxt at_top level (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) | Just thing <- mb_thing , KindLevel <- level - = Right $ KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act } + = Right $ pprKindMismatchMsg thing exp act | Just item <- at_top , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing mismatch = mkBasicMismatchMsg ea item exp act - = Right mismatch + = Right (pprMismatchMsg ctxt mismatch) | otherwise = Left $ if expanded_syns ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5690,19 +5690,9 @@ data MismatchMsg , mismatch_mb_same_occ :: Maybe SameOccInfo } - -- | A type has an unexpected kind. - -- - -- Test cases: T2994, T7609, ... - | KindMismatch - { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? - , kmismatch_expected :: Type - , kmismatch_actual :: Type - } - -- TODO: combine with 'BasicMismatch'. - -- | A mismatch between two types, which arose from a type equality. -- - -- Test cases: T1470, tcfail212. + -- Test cases: T1470, tcfail212, T2994, T7609. | TypeEqMismatch { teq_mismatch_item :: ErrorItem , teq_mismatch_ty1 :: Type ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -420,7 +420,6 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "MultiplicityCoercionsNotSupported" = 59840 -- Type mismatch errors GhcDiagnosticCode "BasicMismatch" = 18872 - GhcDiagnosticCode "KindMismatch" = 89223 GhcDiagnosticCode "TypeEqMismatch" = 83865 GhcDiagnosticCode "CouldNotDeduce" = 05617 ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -46,7 +46,6 @@ [GHC-06200] is untested (constructor = BlockedEquality) [GHC-81325] is untested (constructor = ExpectingMoreArguments) [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt) -[GHC-89223] is untested (constructor = KindMismatch) [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan) [GHC-95822] is untested (constructor = TcRnSimplifierTooManyIterations) [GHC-17268] is untested (constructor = TcRnCharLiteralOutOfRange) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/926464f1e7d9371840c41605888996f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/926464f1e7d9371840c41605888996f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25440] 3 commits: Refactor Handling of Multiple Default Declarations
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00 Refactor Handling of Multiple Default Declarations Fixes: #25912, #25914, #25934 Previously, GHC discarded all loaded defaults (tcg_default) when local defaults were encountered during typechecking. According to the exportable-named-default proposal (sections 2.4.2 and 2.4.3), local defaults should be merged into tcg_default, retaining any defaults already present while overriding where necessary. Key Changes: * Introduce DefaultProvenance to track the origin of default declarations (local, imported, or built-in), replacing the original cd_module in ClassDefaults with cd_provenance :: DefaultProvenance. * Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only converting renamed class defaults into ClassDefaults. * Add extendDefaultEnvWithLocalDefaults to merge local defaults into the environment, with proper duplication checks: - Duplicate local defaults for a class trigger an error. - Local defaults override imported or built-in defaults. * Update and add related notes: Note [Builtin class defaults], Note [DefaultProvenance]. * Add regression tests: T25912, T25914, T25934. Thanks sam and simon for the help on this patch. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00 template-haskell: Remove `addrToByteArrayName` and `addrToByteArray` These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. Resolves #24782 - - - - - 1a6a4b1e by Simon Peyton Jones at 2025-04-18T17:42:14+01:00 Track rewriter sets more accurately in constraint solving The key change, which fixed #25440, is to call `recordRewriter` in GHC.Tc.Solver.Rewrite.rewrite_exact_fam_app. This missing call meant that we were secretly rewriting a Wanted with a Wanted, but not really noticing; and that led to a very bad error message, as you can see in the ticket. But of course that led me into rabbit hole of other refactoring around the RewriteSet code: * Improve Notes [Wanteds rewrite Wanteds] * Zonk the RewriterSet in `zonkCtEvidence` rather than only in GHC.Tc.Errors. This is tidier anyway (e.g. de-clutters debug output), and helps with the next point. * In GHC.Tc.Solver.Equality.inertsCanDischarge, don't replace a constraint with no rewriters with an equal constraint that has many. See See (CE4) in Note [Combining equalities] * Move zonkRewriterSet and friends from GHC.Tc.Zonk.Type into GHC.Tc.Zonk.TcType, where they properly belong. A handful of tests get better error messages. For some reason T24984 gets 12% less compiler allocation -- good Metric Decrease: T24984 - - - - - 33 changed files: - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/DefaultEnv.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/changelog.md - + testsuite/tests/default/T25912.hs - + testsuite/tests/default/T25912.stdout - + testsuite/tests/default/T25912_helper.hs - + testsuite/tests/default/T25914.hs - + testsuite/tests/default/T25934.hs - testsuite/tests/default/all.T - testsuite/tests/default/default-fail03.stderr - testsuite/tests/indexed-types/should_fail/T3330c.stderr - testsuite/tests/indexed-types/should_fail/T4174.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod58.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be011dacff5ef7a07d59ecd52ef5c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be011dacff5ef7a07d59ecd52ef5c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] 3 commits: Comments only
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: b10529e9 by Simon Peyton Jones at 2025-04-18T15:27:53+01:00 Comments only - - - - - e805aa2e by Simon Peyton Jones at 2025-04-18T15:35:54+01:00 Refator GHC.Core.Opt.SetLevels.notWorthFloating I refactored `notWorthFloating` while I was doing something else. I don't think there's a change in behaviour, but if so it's very much a corner case. - - - - - d6c13d5d by Simon Peyton Jones at 2025-04-18T17:16:13+01:00 Always float bottoming expressions to the top ...regardless of floatConsts - - - - - 2 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -482,14 +482,14 @@ Consider this: f :: T Int -> blah f x vs = case x of { MkT y -> let f vs = ...(case y of I# w -> e)...f.. - in f vs + in f vs } Here we can float the (case y ...) out, because y is sure to be evaluated, to give f x vs = case x of { MkT y -> - case y of I# w -> + case y of { I# w -> let f vs = ...(e)...f.. - in f vs + in f vs }} That saves unboxing it every time round the loop. It's important in some DPH stuff where we really want to avoid that repeated unboxing in @@ -614,7 +614,8 @@ lvlMFE env strict_ctxt e@(_, AnnCase {}) = lvlExpr env e -- See Note [Case MFEs] lvlMFE env strict_ctxt ann_expr - | not float_me + | notWorthFloating expr abs_vars + || not float_me || floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed. || hasFreeJoin env fvs -- If there is a free join, don't float @@ -623,9 +624,6 @@ lvlMFE env strict_ctxt ann_expr -- We can't let-bind an expression if we don't know -- how it will be represented at runtime. -- See Note [Representation polymorphism invariants] in GHC.Core - || notWorthFloating expr abs_vars - -- Test notWorhtFloating last; - -- See Note [Large free-variable sets] = -- Don't float it out lvlExpr env ann_expr @@ -676,12 +674,11 @@ lvlMFE env strict_ctxt ann_expr is_function = isFunction ann_expr mb_bot_str = exprBotStrictness_maybe expr -- See Note [Bottoming floats] - -- esp Bottoming floats (2) + -- esp Bottoming floats (BF2) expr_ok_for_spec = exprOkForSpeculation expr abs_vars = abstractVars dest_lvl env fvs dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam - -- NB: is_bot_lam not is_bot; see (3) in - -- Note [Bottoming floats] + -- NB: is_bot_lam not is_bot; see (BF2) in Note [Bottoming floats] -- float_is_new_lam: the floated thing will be a new value lambda -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is @@ -698,20 +695,22 @@ lvlMFE env strict_ctxt ann_expr -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. + -- Never float trivial expressions; + -- notably, save_work might be true of a lone evaluated variable. float_me = saves_work || saves_alloc || is_mk_static -- See Note [Saving work] + is_hnf = exprIsHNF expr saves_work = escapes_value_lam -- (a) - && not (exprIsHNF expr) -- (b) + && not is_hnf -- (b) && not float_is_new_lam -- (c) escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) - -- See Note [Saving allocation] and Note [Floating to the top] - saves_alloc = isTopLvl dest_lvl - && floatConsts env - && ( not strict_ctxt -- (a) - || exprIsHNF expr -- (b) - || (is_bot_lam && escapes_value_lam)) -- (c) + -- See Note [Floating to the top] + saves_alloc = isTopLvl dest_lvl + && ( (floatConsts env && + (not strict_ctxt || is_hnf)) -- (FT1) and (FT2) + || (is_bot_lam && escapes_value_lam)) -- (FT3) hasFreeJoin :: LevelEnv -> DVarSet -> Bool -- Has a free join point which is not being floated to top level. @@ -726,7 +725,7 @@ hasFreeJoin env fvs The key idea in let-floating is to * float a redex out of a (value) lambda Doing so can save an unbounded amount of work. -But see also Note [Saving allocation]. +But see also Note [Floating to the top]. So we definitely float an expression out if (a) It will escape a value lambda (escapes_value_lam) @@ -771,10 +770,12 @@ Wrinkles: we have saved nothing: one pair will still be allocated for each call of `f`. Hence the (not float_is_new_lam) in saves_work. -Note [Saving allocation] -~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Floating to the top] +~~~~~~~~~~~~~~~~~~~~~~~~~~ Even if `saves_work` is false, we we may want to float even cheap/HNF -expressions out of value lambdas, for several reasons: +expressions out of value lambdas. Data suggests, however, that it is better +/only/ to do so, /if/ they can go to top level. If the expression goes to top +level we don't pay the cost of allocating cold-path thunks described in (SW2). * Doing so may save allocation. Consider f = \x. .. (\y.e) ... @@ -782,6 +783,11 @@ expressions out of value lambdas, for several reasons: (assuming e does not mention x). An example where this really makes a difference is simplrun009. +* In principle this would be true even if the (\y.e) didn't go to top level; but + in practice we only float a HNF if it goes all way to the top. We don't pay + /any/ allocation cost for a top-level floated expression; it just becomes + static data. + * It may allow SpecContr to fire on functions. Consider f = \x. ....(f (\y.e)).... After floating we get @@ -793,21 +799,7 @@ expressions out of value lambdas, for several reasons: a big difference for string literals and bottoming expressions: see Note [Floating to the top] -Data suggests, however, that it is better /only/ to float HNFS, /if/ they can go -to top level. See (SW2) of Note [Saving work]. If the expression goes to top -level we don't pay the cost of allocating cold-path thunks described in (SW2). - -Hence `isTopLvl dest_lvl` in `saves_alloc`. - -Note [Floating to the top] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even though Note [Saving allocation] suggests that we should not, in -general, float HNFs, the balance change if it goes to the top: - -* We don't pay an allocation cost for the floated expression; it - just becomes static data. - -* Floating string literal is valuable -- no point in duplicating the +* Floating string literals is valuable -- no point in duplicating the at each call site! * Floating bottoming expressions is valuable: they are always cold @@ -815,32 +807,32 @@ general, float HNFs, the balance change if it goes to the top: can be quite big, inhibiting inlining. See Note [Bottoming floats] So we float an expression to the top if: - (a) the context is lazy (so we get allocation), or - (b) the expression is a HNF (so we get allocation), or - (c) the expression is bottoming and floating would escape a - value lambda (NB: if the expression itself is a lambda, (b) - will apply; so this case only catches bottoming thunks) + (FT1) the context is lazy (so we get allocation), or + (FT2) the expression is a HNF (so we get allocation), or + (FT3) the expression is bottoming and floating would escape a + value lambda (NB: if the expression itself is a lambda, (b) + will apply; so this case only catches bottoming thunks) Examples: -* (a) Strict. Case scrutinee +* (FT1) Strict. Case scrutinee f = case g True of .... Don't float (g True) to top level; then we have the admin of a top-level thunk to worry about, with zero gain. -* (a) Strict. Case alternative +* (FT1) Strict. Case alternative h = case y of True -> g True False -> False Don't float (g True) to the top level -* (b) HNF +* (FT2) HNF f = case y of True -> p:q False -> blah We may as well float the (p:q) so it becomes a static data structure. -* (c) Bottoming expressions; see also Note [Bottoming floats] +* (FT3) Bottoming expressions; see also Note [Bottoming floats] f x = case x of 0 -> error <big thing> _ -> x+1 @@ -853,7 +845,7 @@ Examples: 'foo' anyway. So float bottoming things only if they escape a lambda. -* Arguments +* (FT4) Arguments t = f (g True) Prior to Apr 22 we didn't float (g True) to the top if f was strict. But (a) this only affected CAFs, because if it escapes a value lambda @@ -868,28 +860,6 @@ early loses opportunities for RULES which (needless to say) are important in some nofib programs (gcd is an example). [SPJ note: I think this is obsolete; the flag seems always on.] -Note [Large free-variable sets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #24471 we had something like - x1 = I# 1 - ... - x1000 = I# 1000 - foo = f x1 (f x2 (f x3 ....)) -So every sub-expression in `foo` has lots and lots of free variables. But -none of these sub-expressions float anywhere; the entire float-out pass is a -no-op. - -In lvlMFE, we want to find out quickly if the MFE is not-floatable; that is -the common case. In #24471 it turned out that we were testing `abs_vars` (a -relatively complicated calculation that takes at least O(n-free-vars) time to -compute) for every sub-expression. - -Better instead to test `float_me` early. That still involves looking at -dest_lvl, which means looking at every free variable, but the constant factor -is a lot better. - -ToDo: find a way to fix the bad asymptotic complexity. - Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Mostly we don't float join points at all -- we want them to /stay/ join points. @@ -1053,30 +1023,36 @@ we'd like to float the call to error, to get But, as ever, we need to be careful: -(1) We want to float a bottoming +(BF1) We want to float a bottoming expression even if it has free variables: f = \x. g (let v = h x in error ("urk" ++ v)) Then we'd like to abstract over 'x', and float the whole arg of g: lvl = \x. let v = h x in error ("urk" ++ v) f = \x. g (lvl x) - To achieve this we pass is_bot to destLevel - -(2) We do not do this for lambdas that return - bottom. Instead we treat the /body/ of such a function specially, - via point (1). For example: + To achieve this we pass `is_bot` to destLevel + +(BF2) We do the same for /lambdas/ that return bottom. + Suppose the original lambda had /no/ free vars: + f = \x. ....(\y z. error (y++z))... + then we'd like to float that whole lambda + lvl = \y z. error (y++z) + f = \x. ....lvl.... + If we just floated its bottom-valued body, we might abstract the arguments in + the "wrong" order and end up with this bad result + lvl = \z y. error (y++z) + f = \x. ....(\y z. lvl z y).... + + If the lambda does have free vars, this will happen: f = \x. ....(\y z. if x then error y else error z).... - If we float the whole lambda thus + We float the whole lambda thus lvl = \x. \y z. if x then error y else error z f = \x. ...(lvl x)... - we may well end up eta-expanding that PAP to + And we may well end up eta-expanding that PAP to + lvl = \x. \y z. if b then error y else error z f = \x. ...(\y z. lvl x y z)... + so we get a (small) closure. So be it. - ===> - lvl = \x z y. if b then error y else error z - f = \x. ...(\y z. lvl x z y)... - (There is no guarantee that we'll choose the perfect argument order.) - -(3) If we have a /binding/ that returns bottom, we want to float it to top +(BF3) If we have a /binding/ that returns bottom, we want to float it to top level, even if it has free vars (point (1)), and even it has lambdas. Example: ... let { v = \y. error (show x ++ show y) } in ... @@ -1092,7 +1068,6 @@ But, as ever, we need to be careful: join points (#24768), and floating to the top would abstract over those join points, which we should never do. - See Maessen's paper 1999 "Bottom extraction: factoring error handling out of functional programs" (unpublished I think). @@ -1135,7 +1110,6 @@ float the case (as advocated here) we won't float the (build ...y..) either, so fusion will happen. It can be a big effect, esp in some artificial benchmarks (e.g. integer, queens), but there is no perfect answer. - -} annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id @@ -1152,69 +1126,124 @@ annotateBotStr id n_extra mb_bot_str = id notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - +-- See Note [notWorthFloating] notWorthFloating e abs_vars - = go e (count isId abs_vars) + = go e 0 where - go (Var {}) n = n >= 0 - go (Lit lit) n = assert (n==0) $ - litIsTrivial lit -- Note [Floating literals] - go (Type {}) _ = True - go (Coercion {}) _ = True + n_abs_vars = count isId abs_vars -- See (NWF5) + + go :: CoreExpr -> Int -> Bool + -- (go e n) return True if (e x1 .. xn) is not worth floating + -- where `e` has n trivial value arguments x1..xn + -- See (NWF4) + go (Lit lit) n = assert (n==0) $ + litIsTrivial lit -- See (NWF1) + go (Type {}) _ = True + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = n==0 || go e n -- See (NWF3) + go (Coercion {}) _ = True go (App e arg) n - -- See Note [Floating applications to coercions] - | not (isRuntimeArg arg) = go e n - | n==0 = False - | exprIsTrivial arg = go e (n-1) -- NB: exprIsTrivial arg = go arg 0 - | otherwise = False - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n - go (Case e b _ as) n + | Type {} <- arg = go e n -- Just types, not coercions (NWF2) + | exprIsTrivial arg = go e (n+1) + | otherwise = False -- (f non-triv) is worth floating + + go (Case e b _ as) _ + -- Do not float the `case` part of trivial cases (NWF3) + -- We'll have a look at the RHS when we get there | null as - = go e n -- See Note [Empty case is trivial] - | Just rhs <- isUnsafeEqualityCase e b as - = go rhs n -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - go _ _ = False + = True -- See Note [Empty case is trivial] + | Just {} <- isUnsafeEqualityCase e b as + = True -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + | otherwise + = False -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. + go (Var _) n + | n==0 = True -- Naked variable + | n <= n_abs_vars = True -- (f a b c) is not worth floating if + | otherwise = False -- a,b,c are all abstracted; see (NWF5) -Ditto literal strings (LitString), which we'd like to float to top -level, which is now possible. + go _ _ = False -- Let etc is worth floating -Note [Floating applications to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don’t float out variables applied only to type arguments, since the -extra binding would be pointless: type arguments are completely erased. -But *coercion* arguments aren’t (see Note [Coercion tokens] in -"GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), -so we still want to float out variables applied only to -coercion arguments. +{- Note [notWorthFloating] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +`notWorthFloating` returns True if the expression would be replaced by something +bigger than it is now. One big goal is that floating should be idempotent. Eg +if we replace e with (lvl79 x y) and then run FloatOut again, don't want to +replace (lvl79 x y) with (lvl83 x y)! +For example: + abs_vars = tvars only: return True if e is trivial, + but False for anything bigger + abs_vars = [x] (an Id): return True for trivial, or an application (f x) + but False for (f x x) + +(NWF1) It's important to float Integer literals, so that they get shared, rather + than being allocated every time round the loop. Hence the litIsTrivial. + + Ditto literal strings (LitString), which we'd like to float to top + level, which is now possible. + +(NWF2) We don’t float out variables applied only to type arguments, since the + extra binding would be pointless: type arguments are completely erased. + But *coercion* arguments aren’t (see Note [Coercion tokens] in + "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), + so we still want to float out variables applied only to + coercion arguments. + +(NWF3) Some expressions have trivial wrappers: + - Casts (e |> co) + - Unary-class applications: + - Dictionary applications (MkC meth) + - Class-op applictions (op dict) + - Case of empty alts + - Unsafe-equality case + In all these cases we say "not worth floating", and we do so /regardless/ + of the wrapped expression. The SetLevels stuff may subsequently float the + components of the expression. + + Example: is it worth floating (f x |> co)? No! If we did we'd get + lvl = f x |> co + ...lvl.... + Then we'd do cast worker/wrapper and end up with. + lvl' = f x + ...(lvl' |> co)... + Silly! Better not to float it in the first place. If we say "no" here, + we'll subsequently say "yes" for (f x) and get + lvl = f x + ....(lvl |> co)... + which is what we want. In short: don't float trivial wrappers. + +(NWF4) The only non-trivial expression that we say "not worth floating" for + is an application + f x y z + where the number of value arguments is <= the number of abstracted Ids. + This is what makes floating idempotent. Hence counting the number of + value arguments in `go` + +(NWF5) In #24471 we had something like + x1 = I# 1 + ... + x1000 = I# 1000 + foo = f x1 (f x2 (f x3 ....)) + So every sub-expression in `foo` has lots and lots of free variables. But + none of these sub-expressions float anywhere; the entire float-out pass is a + no-op. -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ + So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where + it obviously /is/ worth floating. (In #24471 it turned out that we were + testing `abs_vars` (a relatively complicated calculation that takes at least + O(n-free-vars) time to compute) for every sub-expression.) -The binding stuff works for top level too. + Hence testing `n_abs_vars only` at the very end. -} +{- ********************************************************************* +* * + Bindings + This binding stuff works for top level too. +* * +********************************************************************* -} + lvlBind :: LevelEnv -> CoreBindWithFVs -> LvlM (LevelledBind, LevelEnv) @@ -1261,7 +1290,7 @@ lvlBind env (AnnNonRec bndr rhs) -- is_bot_lam: looks like (\xy. bot), maybe zero lams -- NB: not isBottomThunk! -- NB: not is_join: don't send bottoming join points to the top. - -- See Note [Bottoming floats] point (3) + -- See Note [Bottoming floats] (BF3) is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty n_extra = count isId abs_vars @@ -1552,9 +1581,8 @@ destLevel env fvs fvs_ty is_function is_bot -- See Note [Floating join point bindings] = tOP_LEVEL - | is_bot -- Send bottoming bindings to the top - = as_far_as_poss -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) and (3) + | is_bot -- Send bottoming bindings to the top regardless; + = as_far_as_poss -- see (BF1) and (BF2) in Note [Bottoming floats] | Just n_args <- floatLams env , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case @@ -1568,8 +1596,13 @@ destLevel env fvs fvs_ty is_function is_bot max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the -- tyvars will be abstracted + -- as_far_as_poss: destination level depends only on the free Ids (more + -- precisely, free CoVars) of the /type/, not the free Ids of the /term/. + -- Why worry about the free CoVars? See Note [Floating and kind casts] + -- + -- There may be free Ids in the term, but then we'll just + -- lambda-abstract over them as_far_as_poss = maxFvLevel' isId env fvs_ty - -- See Note [Floating and kind casts] {- Note [Floating and kind casts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1732,10 +1765,9 @@ maxFvLevel max_me env var_set -- It's OK to use a non-deterministic fold here because maxIn commutes. maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level --- Same but for TyCoVarSet +-- Precisely the same as `maxFvLevel` but for TyCoVarSet rather than DVarSet maxFvLevel' max_me env var_set = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set - -- It's OK to use a non-deterministic fold here because maxIn commutes. maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -801,9 +801,9 @@ makeTrivial env top_lvl dmd occ_fs expr = return (emptyLetFloats, expr) | not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - = return (emptyLetFloats, expr) -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) -- See Note [Cannot trivialise] - | otherwise -- 'expr' is not of form (Cast e co) + | otherwise = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc27b6c9b536a8200cd2b8750e4744… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc27b6c9b536a8200cd2b8750e4744… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25975] Fix bytecode generation for `tagToEnum# <LITERAL>`
by Matthew Craven (＠clyring) 18 Apr '25

18 Apr '25

Matthew Craven pushed to branch wip/T25975 at Glasgow Haskell Compiler / GHC Commits: 6cb3e990 by Matthew Craven at 2025-04-18T08:31:11-04:00 Fix bytecode generation for `tagToEnum# <LITERAL>` Fixes #25975. - - - - - 4 changed files: - compiler/GHC/StgToByteCode.hs - + testsuite/tests/bytecode/T25975.hs - + testsuite/tests/bytecode/T25975.stdout - testsuite/tests/bytecode/all.T Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -1801,10 +1801,14 @@ maybe_getCCallReturnRep fn_ty _ -> pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) +maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t) +maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t) + | [v] <- args = Just (v, extract_constr_Names t) + | otherwise + = pprPanic "StgToByteCode: tagToEnum#" + $ text "Expected exactly one arg, but actual args are:" <+> ppr args where extract_constr_Names ty | rep_ty <- unwrapType ty @@ -1851,13 +1855,13 @@ implement_tagToId :: StackDepth -> Sequel -> BCEnv - -> Id + -> StgArg -> [Name] -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names = assert (notNull names) $ - do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg) + do (push_arg, arg_bytes) <- pushAtom d p arg labels <- getLabelsBc (strictGenericLength names) label_fail <- getLabelBc label_exit <- getLabelBc ===================================== testsuite/tests/bytecode/T25975.hs ===================================== @@ -0,0 +1,27 @@ +-- Tests bytecode generation for tagToEnum# applied to literals +{-# LANGUAGE MagicHash #-} +module Main (main) where + +import GHC.Exts + +f1 :: Int# -> Bool +{-# OPAQUE f1 #-} +f1 v = case v of + 4# -> tagToEnum# v + _ -> False + +f2 :: Int# -> Bool +{-# OPAQUE f2 #-} +f2 v = case v of + 5# -> tagToEnum# 6# + _ -> True + +f3 :: Ordering +f3 = tagToEnum# (noinline runRW# (\_ -> 1#)) + + +main :: IO () +main = do + print $ f1 2# + print $ f2 3# + print f3 ===================================== testsuite/tests/bytecode/T25975.stdout ===================================== @@ -0,0 +1,3 @@ +False +True +EQ ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -1,3 +1,7 @@ ghci_dump_bcos = [only_ways(['ghci']), extra_run_opts('-dno-typeable-binds -dsuppress-uniques -ddump-bcos')] test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_script, ['T23068.script']) + +test('T25975', extra_ways(ghci_ways), compile_and_run, + # Some of the examples work more robustly with these flags + ['-fno-break-points -fno-full-laziness']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cb3e990906148813038a3158076746… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cb3e990906148813038a3158076746… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25975
by Matthew Craven (＠clyring) 18 Apr '25

18 Apr '25

Matthew Craven pushed new branch wip/T25975 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25975 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25440] Wibbles
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: be011dac by Simon Peyton Jones at 2025-04-18T13:12:23+01:00 Wibbles - - - - - 12 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/indexed-types/should_fail/T3330c.stderr - testsuite/tests/indexed-types/should_fail/T4174.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -466,13 +466,12 @@ mkErrorItem ct = do { let loc = ctLoc ct flav = ctFlavour ct - ; (suppress, m_evdest) <- case ctEvidence ct of - -- For this `suppress` stuff - -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint - CtGiven {} -> return (False, Nothing) - CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest }) - -> do { rewriters' <- zonkRewriterSet rewriters - ; return (not (isEmptyRewriterSet rewriters'), Just dest) } + (suppress, m_evdest) = case ctEvidence ct of + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint + CtGiven {} -> (False, Nothing) + CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) + -> (not (isEmptyRewriterSet rws), Just dest) ; let m_reason = case ct of CIrredCan (IrredCt { ir_reason = reason }) -> Just reason @@ -503,7 +502,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , text "tidy_errs =" <+> ppr tidy_errs ]) -- Catch an awkward (and probably rare) case in which /all/ errors are - -- suppressed: see Wrinkle (WRW2) in Note [Prioritise Wanteds with empty + -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty -- RewriterSet] in GHC.Tc.Types.Constraint. -- -- Unless we are sure that an error will be reported some other way ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -1081,9 +1081,9 @@ disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent ; successes <- fmap catMaybes $ nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ mapM firstSuccess proposalSequences - ; traceTcS "disambigProposalSequences" (vcat [ ppr wanteds - , ppr proposalSequences - , ppr successes ]) + ; traceTcS "disambigProposalSequences {" (vcat [ ppr wanteds + , ppr proposalSequences + , ppr successes ]) -- Step (4) in Note [How type-class constraints are defaulted] ; case successes of success@(tvs, subst) : rest ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2077,11 +2077,15 @@ Wrinkles: that `kw`. (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets - solved. This is done in kickOutAfterFillingCoercionHole, which kicks out + solved. This is done in `kickOutAfterFillingCoercionHole`, which kicks out all equalities whose RHS mentions the filled-in coercion hole. Note that it looks for type family equalities, too, because of the use of unifyTest in canEqTyVarFunEq. + To do this, we slightly-hackily use the `ctev_rewriters` field of the inert, + which records that `w` has been rewritten by `kw`. + See (WRW3) in Note [Wanteds reewrite Wanteds] in GHC.Tc.Types.Constraint. + (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The main way is like this. Assume F :: forall k. k -> Type [W] kw : k ~ Type @@ -2615,6 +2619,7 @@ But it's not so simple: error message that we can solve (F a ~ a Int) arising from F a ~ F a Better to hang on to `g1`, in preference to `g2`. + See (WRW1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. -} tryInertEqs :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -150,7 +150,6 @@ import qualified GHC.Tc.Utils.Env as TcM , topIdLvl ) import GHC.Tc.Zonk.Monad ( ZonkM ) import qualified GHC.Tc.Zonk.TcType as TcM -import qualified GHC.Tc.Zonk.Type as TcM import GHC.Driver.DynFlags @@ -489,7 +488,7 @@ kickOutAfterFillingCoercionHole hole kick_out ics@(IC { inert_irreds = irreds }) = -- We only care about irreds here, because any constraint blocked -- by a coercion hole is an irred. See wrinkle (EIK2a) in - -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality (irreds_to_kick, ics { inert_irreds = irreds_to_keep }) where (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds @@ -1457,8 +1456,8 @@ emitWork cts -- c1 is rewritten by another, c2. When c2 gets solved, -- c1 has no rewriters, and can be prioritised; see -- Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint wrinkle (WRW1) - ; cts <- wrapTcS $ mapBagM TcM.zonkCtRewriterSet cts + -- in GHC.Tc.Types.Constraint wrinkle (PER1) + ; cts <- liftZonkTcS $ mapBagM TcM.zonkCtRewriterSet cts ; updWorkListTcS (extendWorkListCts cts) } emitImplication :: Implication -> TcS () @@ -2252,7 +2251,7 @@ wrapUnifierX ev role do_unifications ; wrapTcS $ do { defer_ref <- TcM.newTcRef emptyBag ; unified_ref <- TcM.newTcRef [] - ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev) + ; rewriters <- TcM.liftZonkM (TcM.zonkRewriterSet (ctEvRewriters ev)) ; let env = UE { u_role = role , u_rewriters = rewriters , u_loc = ctEvLoc ev ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -240,7 +240,7 @@ instance Outputable DictCt where {- Note [Canonical equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An EqCt is a canonical equality constraint, one that can live in the inert set, -and that can be used to rewrite other constrtaints. It satisfies these invariants: +and that can be used to rewrite other constraints. It satisfies these invariants: * (TyEq:OC) lhs does not occur in rhs (occurs check) Note [EqCt occurs check] * (TyEq:F) rhs has no foralls @@ -2444,19 +2444,29 @@ We thus want Wanteds to rewrite Wanteds in order to accept more programs, but we don't want Wanteds to rewrite Wanteds because doing so can create inscrutable error messages. To solve this dilemma: -* We allow Wanteds to rewrite Wanteds, but... +* We allow Wanteds to rewrite Wanteds, but each Wanted tracks the set of Wanteds + it has been rewritten by, in its RewriterSet, stored in the ctev_rewriters + field of the CtWanted constructor of CtEvidence. (Only Wanteds have + RewriterSets.) -* Each Wanted tracks the set of Wanteds it has been rewritten by, in its - RewriterSet, stored in the ctev_rewriters field of the CtWanted - constructor of CtEvidence. (Only Wanteds have RewriterSets.) +* A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient + because only equalities (evidenced by coercion holes) are used for rewriting; + other (dictionary) constraints cannot ever rewrite. + +* The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, + consisting of the evidence (a CoercionHole) for any Wanted equalities used in + rewriting. + +* Then GHC.Tc.Solver.Solve.rewriteEvidence and GHC.Tc.Solver.Equality.rewriteEqEvidence + add this RewriterSet to the rewritten constraint's rewriter set. * In error reporting, we simply suppress any errors that have been rewritten by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, - which uses GHC.Tc.Zonk.Type.zonkRewriterSet to look through any filled + which uses `GHC.Tc.Zonk.Type.zonkRewriterSet` to look through any filled coercion holes. The idea is that we wish to report the "root cause" -- the error that rewrote all the others. -* We prioritise Wanteds that have an empty RewriterSet: +* In error reporting, we prioritise Wanteds that have an empty RewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]. Let's continue our first example above: @@ -2471,19 +2481,30 @@ Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding The {w1} in the second line of output is the RewriterSet of w1. -A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient -because only equalities (evidenced by coercion holes) are used for rewriting; -other (dictionary) constraints cannot ever rewrite. The rewriter (in -e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, -consisting of the evidence (a CoercionHole) for any Wanted equalities used in -rewriting. Then GHC.Tc.Solver.Solve.rewriteEvidence and -GHC.Tc.Solver.Equality.rewriteEqEvidence add this RewriterSet to the rewritten -constraint's rewriter set. +Wrinkles: + +(WRW1) When we find a constraint identical to one already in the inert set, + we solve one from the other. Other things being equal, keep the one + that has fewer (better still no) rewriters. + See (CE4) in Note [Combining equalities] in GHC.Tc.Solver.Equality. + + To this accurately we should use `zonkRewriterSet` during canonicalisation, + to eliminate rewriters that have now been solved. Currently we only do so + during error reporting; but perhaps we should change that. + +(WRW2) When zonk a constraint (with `zonkCt` and `zonkCtEvidence`) we take + the opportunity to zonk its `RewriterSet, which eliminates solved ones`. + This doesn't guarantee that rewriter sets are always up to date -- see + (WRW1) -- but it helps, and it de-clutters debug output. + +(WRW3) We use the rewriter set for a slightly different purpose, in (EIK2) + of Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality. + This is a bit of a hack. Note [Prioritise Wanteds with empty RewriterSet] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq, -we priorities constraints that have no rewriters. Here's why. +we prioritise constraints that have no rewriters. Here's why. Consider this, which came up in T22793: inert: {} @@ -2527,11 +2548,11 @@ GHC.Tc.Solver.InertSet.extendWorkListEq, and extendWorkListEqs. Wrinkles -(WRW1) Before checking for an empty RewriterSet, we zonk the RewriterSet, +(PER1) Before checking for an empty RewriterSet, we zonk the RewriterSet, because some of those CoercionHoles may have been filled in since we last looked: see GHC.Tc.Solver.Monad.emitWork. -(WRW2) Despite the prioritisation, it is hard to be /certain/ that we can't end up +(PER2) Despite the prioritisation, it is hard to be /certain/ that we can't end up in a situation where all of the Wanteds have rewritten each other. In order to report /some/ error in this case, we simply report all the Wanteds. The user will get a perhaps-confusing error message, but they've ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -49,7 +49,6 @@ module GHC.Tc.Utils.TcMType ( newCoercionHole, newCoercionHoleO, newVanillaCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, checkCoercionHole, newImplication, @@ -115,7 +114,6 @@ import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin ) import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types -import GHC.Tc.Zonk.Type import GHC.Tc.Zonk.TcType import GHC.Builtin.Names @@ -1583,7 +1581,7 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co go_co dv (SubCo co) = go_co dv co go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole + = do m_co <- liftZonkM (unpackCoercionHole_maybe hole) case m_co of Just co -> go_co dv co Nothing -> go_cv dv (coHoleCoVar hole) ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 @@ -36,6 +38,13 @@ module GHC.Tc.Zonk.TcType -- ** Zonking constraints , zonkCt, zonkWC, zonkSimples, zonkImplication + -- * Rewriter sets + , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet + + -- * Coercion holes + , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe + + -- * Tidying , tcInitTidyEnv, tcInitOpenTidyEnv , tidyCt, tidyEvVar, tidyDelayedError @@ -81,7 +90,7 @@ import GHC.Core.Coercion import GHC.Core.Predicate import GHC.Utils.Constants -import GHC.Utils.Outputable +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Panic @@ -89,6 +98,9 @@ import GHC.Utils.Panic import GHC.Data.Bag import GHC.Data.Pair +import Data.Semigroup +import Data.Maybe + {- ********************************************************************* * * Writing to metavariables @@ -366,8 +378,8 @@ checkCoercionHole cv co ; return $ assertPpr (ok cv_ty) (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) + ppr cv Outputable.<> colon + <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ]) co } | otherwise = return co @@ -494,9 +506,15 @@ zonkCt ct ; return (mkNonCanonical fl') } zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence -zonkCtEvidence ctev - = do { pred' <- zonkTcType (ctEvPred ctev) - ; return (setCtEvPredType ctev pred') } +-- Zonks the ctev_pred and the ctev_rewriters; but not ctev_evar +-- For ctev_rewriters, see (WRW2) in Note [Wanteds rewrite Wanteds] +zonkCtEvidence (CtGiven (GivenCt { ctev_pred = pred, ctev_evar = var, ctev_loc = loc })) + = do { pred' <- zonkTcType pred + ; return (CtGiven (GivenCt { ctev_pred = pred', ctev_evar = var, ctev_loc = loc })) } +zonkCtEvidence (CtWanted wanted@(WantedCt { ctev_pred = pred, ctev_rewriters = rws })) + = do { pred' <- zonkTcType pred + ; rws' <- zonkRewriterSet rws + ; return (CtWanted (wanted { ctev_pred = pred', ctev_rewriters = rws' })) } zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk @@ -530,6 +548,103 @@ win. But c.f Note [Sharing when zonking to Type] in GHC.Tc.Zonk.Type. +%************************************************************************ +%* * + Zonking rewriter sets +* * +************************************************************************ +-} + +zonkCtRewriterSet :: Ct -> ZonkM Ct +zonkCtRewriterSet ct + | isGivenCt ct + = return ct + | otherwise + = case ct of + CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CEqCan (eq { eq_ev = ev' })) } + CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CDictCan (di { di_ev = ev' })) } + CQuantCan {} -> return ct + CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CNonCanonical ev') } + +zonkCtEvRewriterSet :: CtEvidence -> ZonkM CtEvidence +zonkCtEvRewriterSet ev@(CtGiven {}) + = return ev +zonkCtEvRewriterSet ev@(CtWanted wtd) + = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) + ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } + +-- | Check whether any coercion hole in a RewriterSet is still unsolved. +-- Does this by recursively looking through filled coercion holes until +-- one is found that is not yet filled in, at which point this aborts. +zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet +zonkRewriterSet (RewriterSet set) + = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set + -- this does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> ZonkM RewriterSet -> ZonkM RewriterSet + go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc + + check_hole :: CoercionHole -> ZonkM RewriterSet + check_hole hole = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) + Just co -> unUCHM (check_co co) } + + check_ty :: Type -> UnfilledCoercionHoleMonoid + check_co :: Coercion -> UnfilledCoercionHoleMonoid + (check_ty, _, check_co, _) = foldTyCo folder () + + folder :: TyCoFolder () UnfilledCoercionHoleMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> check_ty (varType cv) + , tcf_hole = \ _ -> UCHM . check_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: ZonkM RewriterSet } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return emptyRewriterSet) + + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> ZonkM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) + = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> ZonkM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + + +{- %************************************************************************ %* * Tidying ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -28,12 +28,6 @@ module GHC.Tc.Zonk.Type ( -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers module GHC.Tc.Zonk.Env, - -- * Coercion holes - isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe, - - -- * Rewriter sets - zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet, - -- * Tidying tcInitTidyEnv, tcInitOpenTidyEnv, @@ -55,7 +49,6 @@ import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) -import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Env @@ -88,7 +81,6 @@ import GHC.Types.Id import GHC.Types.TypeEnv import GHC.Types.Basic import GHC.Types.SrcLoc -import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.TyThing @@ -99,7 +91,6 @@ import GHC.Data.Bag import Control.Monad import Control.Monad.Trans.Class ( lift ) -import Data.Semigroup import Data.List.NonEmpty ( NonEmpty ) import Data.Foldable ( toList ) @@ -1956,89 +1947,3 @@ finding the free type vars of an expression is necessarily monadic operation. (consider /\a -> f @ b, where b is side-effected to a) -} -{- -************************************************************************ -* * - Checking for coercion holes -* * -************************************************************************ --} - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) - = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - -zonkCtRewriterSet :: Ct -> TcM Ct -zonkCtRewriterSet ct - | isGivenCt ct - = return ct - | otherwise - = case ct of - CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CEqCan (eq { eq_ev = ev' })) } - CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CIrredCan (ir { ir_ev = ev' })) } - CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CDictCan (di { di_ev = ev' })) } - CQuantCan {} -> return ct - CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CNonCanonical ev') } - -zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence -zonkCtEvRewriterSet ev@(CtGiven {}) - = return ev -zonkCtEvRewriterSet ev@(CtWanted wtd) - = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) - ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } - --- | Check whether any coercion hole in a RewriterSet is still unsolved. --- Does this by recursively looking through filled coercion holes until --- one is found that is not yet filled in, at which point this aborts. -zonkRewriterSet :: RewriterSet -> TcM RewriterSet -zonkRewriterSet (RewriterSet set) - = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set - -- this does not introduce non-determinism, because the only - -- monadic action is to read, and the combining function is - -- commutative - where - go :: CoercionHole -> TcM RewriterSet -> TcM RewriterSet - go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc - - check_hole :: CoercionHole -> TcM RewriterSet - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return (unitRewriterSet hole) - Just co -> unUCHM (check_co co) } - - check_ty :: Type -> UnfilledCoercionHoleMonoid - check_co :: Coercion -> UnfilledCoercionHoleMonoid - (check_ty, _, check_co, _) = foldTyCo folder () - - folder :: TyCoFolder () UnfilledCoercionHoleMonoid - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) - , tcf_covar = \ _ cv -> check_ty (varType cv) - , tcf_hole = \ _ -> UCHM . check_hole - , tcf_tycobinder = \ _ _ _ -> () } - -newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM RewriterSet } - -instance Semigroup UnfilledCoercionHoleMonoid where - UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) - -instance Monoid UnfilledCoercionHoleMonoid where - mempty = UCHM (return emptyRewriterSet) ===================================== testsuite/tests/indexed-types/should_fail/T3330c.stderr ===================================== @@ -1,16 +1,24 @@ - -T3330c.hs:25:43: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - f1 :: * -> * - f1 x :: * - Expected: Der ((->) x) (Der f1 x) - Actual: R f1 - • In the first argument of ‘plug’, namely ‘rf’ +T3330c.hs:25:38: error: [GHC-25897] + • Could not deduce ‘Der f1 ~ f1’ + from the context: f ~ (f1 :+: g) + bound by a pattern with constructor: + RSum :: forall (f :: * -> *) (g :: * -> *). + R f -> R g -> R (f :+: g), + in an equation for ‘plug'’ + at T3330c.hs:25:8-17 + Expected: x -> f1 x + Actual: x -> Der f1 x + ‘f1’ is a rigid type variable bound by + a pattern with constructor: + RSum :: forall (f :: * -> *) (g :: * -> *). + R f -> R g -> R (f :+: g), + in an equation for ‘plug'’ + at T3330c.hs:25:8-17 + • The function ‘plug’ is applied to three visible arguments, + but its type ‘Rep f => Der f x -> x -> f x’ has only two In the first argument of ‘Inl’, namely ‘(plug rf df x)’ In the expression: Inl (plug rf df x) • Relevant bindings include - x :: x (bound at T3330c.hs:25:29) df :: Der f1 x (bound at T3330c.hs:25:25) rf :: R f1 (bound at T3330c.hs:25:13) - plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:25:1) + ===================================== testsuite/tests/indexed-types/should_fail/T4174.stderr ===================================== @@ -1,6 +1,16 @@ - -T4174.hs:45:12: error: [GHC-18872] - • Couldn't match type ‘False’ with ‘True’ - arising from a use of ‘sync_large_objects’ +T4174.hs:45:12: error: [GHC-25897] + • Couldn't match type ‘a’ with ‘SmStep’ + Expected: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual: m (Field (WayOf m) SmStep RtsSpinLock) + ‘a’ is a rigid type variable bound by + the type signature for: + testcase :: forall (m :: * -> *) minor n t p a b. + Monad m => + m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:44:1-63 • In the expression: sync_large_objects In an equation for ‘testcase’: testcase = sync_large_objects + • Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:45:1) + ===================================== testsuite/tests/indexed-types/should_fail/T8227.stderr ===================================== @@ -13,12 +13,3 @@ T8227.hs:24:27: error: [GHC-83865] absoluteToParam :: Scalar (V a) -> a -> Scalar (V a) (bound at T8227.hs:24:1) -T8227.hs:24:48: error: [GHC-27958] - • Couldn't match type ‘p0’ with ‘Scalar (V p0)’ - arising from a type equality Scalar (V a) ~ Scalar (V p0) -> p0 - The type variable ‘p0’ is ambiguous - • In the second argument of ‘arcLengthToParam’, namely ‘eps’ - In the expression: arcLengthToParam eps eps - In an equation for ‘absoluteToParam’: - absoluteToParam eps seg = arcLengthToParam eps eps - ===================================== testsuite/tests/typecheck/should_fail/T18851.stderr ===================================== @@ -1,7 +1,7 @@ - T18851.hs:35:5: error: [GHC-18872] - • Couldn't match type ‘B’ with ‘A’ - arising from a superclass required to satisfy ‘C int0 A’, + • Couldn't match type ‘Bool’ with ‘B’ + arising from a superclass required to satisfy ‘C Int B’, arising from a use of ‘f’ • In the expression: f @A @B In an equation for ‘g’: g = f @A @B + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be011dacff5ef7a07d59ecd52ef5c6e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be011dacff5ef7a07d59ecd52ef5c6e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25974
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin pushed new branch wip/T25974 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25974 You're receiving this email because of your account on gitlab.haskell.org.

1 0