- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-reinstallable-base2] rebindable for EPoll
by Rodrigo Mesquita (＠alt-romes) 12 Jun '26

12 Jun '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 6c4f54f9 by Rodrigo Mesquita at 2026-06-12T17:01:22+01:00 rebindable for EPoll - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc ===================================== @@ -22,6 +22,7 @@ module GHC.Internal.Event.EPoll ) where import qualified GHC.Internal.Event.Internal as E +import qualified GHC.Internal.Stack.Types as Rebindable import qualified GHC.Internal.Base as Rebindable -- For known-key names #include "EventConfig.h" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4f54f938f1d405de0079980bffda8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4f54f938f1d405de0079980bffda8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 10 commits: Revert "Better specification for when to disable defaulting"
by Rodrigo Mesquita (＠alt-romes) 12 Jun '26

12 Jun '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: bffa37b8 by Rodrigo Mesquita at 2026-06-12T10:15:58+01:00 Revert "Better specification for when to disable defaulting" This reverts commit ac878ff32e63933b1f4268c7005129ebf3b85df6. - - - - - 54d9d6cf by Rodrigo Mesquita at 2026-06-12T10:22:23+01:00 undo changes to defaulting - - - - - 2495294b by Rodrigo Mesquita at 2026-06-12T14:21:37+01:00 Use structured error representation for missing GHC.Essentials Adds test T27013e to observe error - - - - - 43c33171 by Rodrigo Mesquita at 2026-06-12T14:35:48+01:00 augment err mesg - - - - - f7b1ed81 by Rodrigo Mesquita at 2026-06-12T15:13:29+01:00 fix augment - - - - - 0c2eb2d9 by Rodrigo Mesquita at 2026-06-12T16:05:10+01:00 Improve failure error when looking up the module directly And improve flag description, noting the implicit dependency. - - - - - def6b32e by Rodrigo Mesquita at 2026-06-12T16:09:04+01:00 SCS5 isSolvedWC fixes Num needed for composition - - - - - 5bb55594 by Rodrigo Mesquita at 2026-06-12T16:10:41+01:00 fixup! Improve failure error when looking up the module directly - - - - - b561913d by Rodrigo Mesquita at 2026-06-12T16:53:37+01:00 testsuite: -frebindable-known-names forces a dependency Therefore, to compile a module with -hide-all-packages, regardless of whether or not it uses known-names, we need -frebindable-known-names to tell GHC to not add that implicit dependency. Also a test that checks the error message when we don't have that flag. - - - - - 7e9c113b by Rodrigo Mesquita at 2026-06-12T16:57:03+01:00 typo - - - - - 18 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/Error/Codes.hs - docs/users_guide/separate_compilation.rst - testsuite/tests/cabal/T27013a/Makefile - testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -372,11 +372,6 @@ Wrinkles keeps types and classes in the global type envt, but `Id`s in the local type envt. (Ids move to the global type env during zonking; see `zonkTopDecls`.) -(KN5) If we are not using -frebindable-known-names, yet GHC.Essentials is still not - in scope, then we don't add the `default Num (Integer, Double)` declaration - to the module being compiled. This relaxation makes it possible for a library - which does not use any known-key at all (namely: `composition`) to compile - successfully without a dependency on base nor ghc-internal. Note [Recipe for adding a known-occ name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -25,6 +25,7 @@ module GHC.Iface.Errors.Ppr import GHC.Prelude import GHC.Builtin( knownKeyOccName_maybe ) +import GHC.Builtin.Modules( eSSENTIALS_NAME ) import GHC.Types.Error import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Error.Codes @@ -67,6 +68,7 @@ interfaceErrorHints = \ case MissingKnownKey2 {} -> noHints MissingKnownKey3 {} -> noHints KnownKeyScopeError {} -> noHints + CantFindEssentials {} -> noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -93,6 +95,7 @@ interfaceErrorReason (MissingKnownKey1 {}) = ErrorWithoutFlag interfaceErrorReason (MissingKnownKey2 {}) = ErrorWithoutFlag interfaceErrorReason (MissingKnownKey3 {}) = ErrorWithoutFlag interfaceErrorReason (KnownKeyScopeError {}) = ErrorWithoutFlag +interfaceErrorReason (CantFindEssentials {}) = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -321,6 +324,32 @@ interfaceErrorDiagnostic opts = \ case -> hang (text "Known-key entity" <+> quotes (ppr occ)) 2 (text "is ambiguous in the top-level global environment" $$ ppr gres) + CantFindEssentials err reason -> + vcat + [ vcat [ hang (text "Failed to load the known-names module" <+> quotes (ppr eSSENTIALS_NAME) <+> text "from the visible packages") + 2 (case reason of + UnknownLoadEssentialsReason -> empty + LookingForKnownOcc occ -> text "while looking for known-occ name" <+> quotes (ppr occ) + LookingForKnownKey key -> text "while looking for known-key" <+> quotes (pprKnownKey key) + LookingForEssentialsModule -> text "while trying to discover its package") + , text "Did you mean to use" <+> quotes (text "-package base") <> text "?" ] + , blankLine + , missingInterfaceErrorDiagnostic opts err + , blankLine + , case reason of + LookingForEssentialsModule + -> vcat [ text "This error was triggered while trying to discover the package of" <+> quotes (ppr eSSENTIALS_NAME) <> comma + , text "rather than when looking up any specific known-name." + , text "If you want to enforce" <+> quotes (ppr eSSENTIALS_NAME) <+> text "is not added to the module graph implicitly," + , text "you should use" <+> quotes (text "-frebindable-known-names") + ] + _ -> hang (text "To lookup known-names in scope rather than in GHC.Essentials" <> comma) + 2 (vcat [ text "use" <+> quotes (text "-frebindable-known-names") <> comma <+> text "and import" + , text "the necessary known-names definitions from" <+> quotes (text "ghc-internal") <> dot + -- Alternatively, you may want to unsafely provide your own GHC.Essentials exposing the known-names you need in scope." + ]) + ] + lookingForHerald :: InterfaceLookingFor -> SDoc lookingForHerald looking_for = case looking_for of ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Iface.Errors.Types ( , FindingModuleOrInterface(..) , BuildingCabalPackage(..) + , LoadEssentialsReason(..) , IfaceMessageOpts(..) @@ -70,6 +71,15 @@ data IfaceMessage -- We looked up a known-occ in the GlobalRdrEnv, -- but did not find a unique hit -- CallStack is so that we can get a backtrace + + | CantFindEssentials MissingInterfaceError LoadEssentialsReason + -- We failed to find GHC.Essentials, the module exported from base which + -- exports all the compiler known-names. The 'MissingInterfaceError' is + -- the underlying reason the module could not be found. A 'KnownKey' is + -- attached if we were looking for one when we failed to load GHC.Essentials + -- + -- Test cases: + -- tests/driver/T27013e deriving Generic data MissingInterfaceError @@ -113,3 +123,11 @@ data BuildingCabalPackage = YesBuildingCabalPackage | NoBuildingCabalPackage deriving Eq + +data LoadEssentialsReason + = LookingForKnownKey KnownKey + | LookingForKnownOcc KnownOcc + | LookingForEssentialsModule + | UnknownLoadEssentialsReason + deriving Generic + ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -73,7 +73,6 @@ import GHC.Iface.Binary import GHC.Iface.Rename import GHC.Iface.Env import GHC.Iface.Errors as Iface_Errors -import GHC.Iface.Errors.Ppr( defaultIfaceMessageOpts, missingInterfaceErrorDiagnostic ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad @@ -188,8 +187,12 @@ lookupKnownKeyName :: HasDebugCallStack => KnownKey -> KnownEntitySource -> IfM lcl (MaybeErr IfaceMessage Name) lookupKnownKeyName key KES_FromModule - = do { (kk_map, _) <- loadKnownKeyOccMaps - ; return $ lookupKnownKeysMap kk_map key } + = do { mb_maps <- loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownKey key)) + Failed err -> Failed err + Succeeded (kk_map, _) -> lookupKnownKeysMap kk_map key } lookupKnownKeyName key (KES_InScope { ke_rdr_env = gbl_rdr_env }) -- Just gbl_rdr_env: we have -frebindable-known-names on, and @@ -240,10 +243,15 @@ lookupKnownOccName :: HasDebugCallStack => KnownOcc -> KnownEntitySource -> IfM lcl (MaybeErr IfaceMessage Name) lookupKnownOccName occ KES_FromModule - = do { (_, occ_map) <- loadKnownKeyOccMaps - ; case lookupOccEnv occ_map occ of - Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey3 occ)) } + = do { mb_maps <- loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownOcc occ)) + Failed err -> Failed err + Succeeded (_, occ_map) -> + case lookupOccEnv occ_map occ of + Just name -> Succeeded name + Nothing -> Failed (MissingKnownKey3 occ) } lookupKnownOccName occ (KES_InScope { ke_rdr_env = gbl_rdr_env }) -- Just gbl_rdr_env: we have -frebindable-known-names on, and @@ -279,23 +287,29 @@ lookupKnownName kk_ns name where name_mod = nameModule name -loadKnownKeyOccMaps :: IfM lcl KnownKeyNameMaps +loadKnownKeyOccMaps :: IfM lcl (MaybeErr IfaceMessage KnownKeyNameMaps) loadKnownKeyOccMaps = do { eps <- getEps ; case eps_known_keys eps of { - Just (kk_maps, _) -> return kk_maps ; + Just (kk_maps, _) -> return (Succeeded kk_maps) ; Nothing -> -- We don't have a KnownKeyOccMap yet, so create it -- from the interface file for KnownKeyName do { hsc_env <- getTopEnv ; mb_res <- liftIO $ findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual - ; iface <- case mb_res of - Found _ mod -> loadInterfaceWithException doc mod ImportBySystem - fr -> do { hsc_env <- getTopEnv - ; pprPanic "loadKnownKeyOccMap" $ - missingInterfaceErrorDiagnostic defaultIfaceMessageOpts $ - cannotFindModule hsc_env eSSENTIALS_NAME fr } + ; case mb_res of + Found _ mod -> Succeeded <$> build_maps mod + fr -> return (Failed (CantFindEssentials + (cannotFindModule hsc_env eSSENTIALS_NAME fr) + UnknownLoadEssentialsReason)) + } } } + where + doc = text "Need interface for KnownKeyNames" + + build_maps :: Module -> IfM lcl KnownKeyNameMaps + build_maps mod + = do { iface <- loadInterfaceWithException doc mod ImportBySystem ; let kk_map :: UniqFM KnownKey Name -- Domain is just the KnownKeys in the knownKeyTable @@ -318,9 +332,7 @@ loadKnownKeyOccMaps (msg $$ text "Known-key occ-map" <+> ppr occ_map) Nothing -> return () #endif - ; return (kk_map, occ_map) } } } - where - doc = text "Need interface for KnonwKeyNames" + ; return (kk_map, occ_map) } lookupKnownKeysMap :: UniqFM KnownKey Name -> KnownKey -> MaybeErr IfaceMessage Name lookupKnownKeysMap kk_map key = case lookupUFM kk_map key of @@ -361,10 +373,13 @@ lookupKnownKeysModule hsc_env dflags = do found_essentials <- findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual let rebindable_kn = gopt Opt_RebindableKnownNames dflags let essentials_uid - | rebindable_kn = Nothing - | Found _ mod <- found_essentials = Just mod - | otherwise = Nothing - return essentials_uid + | rebindable_kn = return Nothing + | Found _ mod <- found_essentials = return (Just mod) + | fr <- found_essentials = do + throwOneError (initSourceErrorContext dflags) $ + mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInterfaceError $ + CantFindEssentials (cannotFindModule hsc_env eSSENTIALS_NAME fr) LookingForEssentialsModule + essentials_uid {- ********************************************************************* * * ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Prelude import GHC.Iface.Load import GHC.Iface.Env -import GHC.Iface.Errors.Types( IfaceMessage(..) ) +import GHC.Iface.Errors.Types( IfaceMessage(..), LoadEssentialsReason (..) ) import GHC.Hs import GHC.Types.Name.Reader @@ -1044,10 +1044,15 @@ lookup_known_occ :: HasDebugCallStack => KnownEntitySource -> KnownOcc -> RnM (MaybeErr IfaceMessage Name) lookup_known_occ KES_FromModule occ - = do { (_, occ_map) <- initIfaceTcRn loadKnownKeyOccMaps - ; case lookupOccEnv occ_map occ of - Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey3 occ)) } + = do { mb_maps <- initIfaceTcRn loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownOcc occ)) + Failed err -> Failed err + Succeeded (_, occ_map) -> + case lookupOccEnv occ_map occ of + Just name -> Succeeded name + Nothing -> Failed (MissingKnownKey3 occ) } lookup_known_occ (KES_InScope { ke_rdr_env = rdr_env }) occ = case lookupKnownGRE rdr_env occ of ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -1006,7 +1006,7 @@ applyDefaultingRules :: WantedConstraints -> TcS Bool -- See Note [How type-class constraints are defaulted] applyDefaultingRules wanteds - | isEmptyWC wanteds + | isSolvedWC wanteds -- not isEmptyWC, see (SCS5) in Note [Shortcut solving] = return False | otherwise = do { (default_env, extended_rules) <- getDefaultInfo ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -671,6 +671,10 @@ Some wrinkles: don't want to reject short-cut solving just because we have some leftover /solved/ implications. #26805 was a case in point. +(SCS5) Similarly to (SCS4), `applyDefaultingRules` should use `isSolvedWC` not + `isEmptyWC`. This avoids unnecessarily trying defaulting rules on solved + constraints. + Note [Shortcut solving: incoherence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This optimization relies on coherence of dictionaries to be correct. When we ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -83,7 +83,6 @@ import GHC.Driver.DynFlags import GHC.Builtin( isUnboundName ) import GHC.Builtin.KnownKeys import GHC.Builtin.WiredIn.Types -import GHC.Builtin.Modules ( eSSENTIALS_NAME ) import GHC.Runtime.Context @@ -116,7 +115,6 @@ import GHC.Unit.Home import GHC.Unit.Home.Graph import GHC.Unit.Home.ModInfo import GHC.Unit.External -import GHC.Unit.Finder import GHC.Utils.Outputable import GHC.Utils.Panic @@ -139,7 +137,6 @@ import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader import GHC.Types.TyThing -import GHC.Types.PkgQual import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt @@ -1119,9 +1116,7 @@ tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types Bool) -- True <=> Use extended defaulting rules tcGetDefaultTys = do { dflags <- getDynFlags - ; hsc_env <- getTopEnv ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - rebindable_kn = gopt Opt_RebindableKnownNames dflags extended_defaults = xopt LangExt.ExtendedDefaultRules dflags -- See also #1974 builtinDefaults cls tys = ClassDefaults{ cd_class = cls @@ -1133,17 +1128,11 @@ tcGetDefaultTys ; user_defaults <- getDeclaredDefaultTys -- User-supplied defaults ; this_module <- tcg_mod <$> getGblEnv ; let this_unit = moduleUnit this_module - ; found_essentials <- liftIO $ findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual - ; case (found_essentials, rebindable_kn) of - (NotFound{}, False) -> -- See Wrinkle (KN5) in Note [Overview of known entities] - -- If GHC.Essentials isn't available at all when -fno-rebindable-known-names - -- don't add the built-in defaulting, bc e.g. Num is a known-entity. - return (user_defaults, extended_defaults) - _ | this_unit == ghcInternalUnit -> - -- see Remark [No built-in defaults in ghc-internal] - -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env - return (user_defaults, extended_defaults) - _ -> do + ; if this_unit == ghcInternalUnit -- if we wanted, this needn't be about ghc-internal + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env + then return (user_defaults, extended_defaults) + else do -- Not one of the built-in units -- @default Num (Integer, Double)@, plus extensions { extDef <- if extended_defaults ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -893,6 +893,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "MissingKnownKey2" = 71344 GhcDiagnosticCode "MissingKnownKey3" = 71345 GhcDiagnosticCode "KnownKeyScopeError" = 99040 + GhcDiagnosticCode "CantFindEssentials" = 49917 -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1665,11 +1665,15 @@ flags: :type: dynamic :category: - This flag is off by default. It is typically set when compiling modules - in ``ghc-internal`` or ``base``, and tells GHC to look for a known - entity in the current top-level scope. When the flag is un-set, GHC looks - for the module ``base:GHC.KnownKeyNames``, but this module does not exist - when compiling ``ghc-internal`` or ``base``, which is why the flag is needed. + This flag is off by default. It tells GHC to look for a known entity in + the current top-level scope. When the flag is off, GHC looks for known + entities in the exports of module ``GHC.Essentials``. + + It is typically set when compiling modules in ``ghc-internal`` or ``base``, + since ``GHC.Essentials`` does not yet exist when compiling those packages. + + GHC must assume ``GHC.Essentials`` is an implicit module dependency when + and only when ``-fno-rebindable-known-names``. .. ghc-flag:: -fdefines-known-key-names :shortdesc: This module defines a known name ===================================== testsuite/tests/cabal/T27013a/Makefile ===================================== @@ -6,16 +6,16 @@ SETUP=./Setup -v0 # Reproducer for #27013 (!15899#note_676801). # -# The `composition` package depends on neither `base` nor `ghc-internal` -# (see composition.cabal: no build-depends). It uses NoImplicitPrelude -# and defines its own `(.)`. Building it should not require GHC to load -# known-key modules from `base` such as `GHC.Essentials`. +# `composition` depends on neither base nor ghc-internal and uses no known-key +# names AT ALL. We pass -frebindable-known-names just so GHC doesn't force an +# implicit GHC.Essentials dependency (which couldn't be solved because of +# -hide-all-packages). See T27013f for the failure when the flag is omitted. T27013a: clean '$(GHC_PKG)' init tmp.d '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup $(SETUP) clean - $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=tmp.d + $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS) -frebindable-known-names' --package-db=tmp.d $(SETUP) build clean : ===================================== testsuite/tests/cabal/T27013d/Makefile ===================================== @@ -2,15 +2,18 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -# Test that compiling Data.Composition without implicit Prelude does not -# recompile the second or third time. The `composition` package's -# Data.Composition uses NoImplicitPrelude and depends on neither base nor -# ghc-internal. In !15899, it was recompiled because of an incorrect -# "GHC.Essentials package changed". +# Test that compiling Data.Composition with -hide-all-packages and +# -XNoImplicitPrelude does not recompile the second or third time. In !15899, +# it used to recompile because of an incorrect "GHC.Essentials package changed". +# +# We pass -frebindable-known-names so GHC doesn't force an implicit +# GHC.Essentials dependency: despite this module not using known-key names, +# -hide-all-packages means we can't find GHC.Essentials when it is added as an +# implicit dependency. clean: rm -f *.o *.hi T27013d: clean - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names ===================================== testsuite/tests/driver/T27013e/T27013e.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- This module is compiled with -hide-all-packages (see all.T), so neither +-- base nor GHC.Essentials can be found. The numeric literal forces GHC to +-- look up the known-key 'fromInteger', which it tries to resolve via the +-- exports of GHC.Essentials. Since GHC.Essentials cannot be found and +-- -frebindable-known-names is not in effect, this fails. +-- +-- We want a structured, helpful error here rather than a panic; see +-- GHC.Iface.Load.loadKnownKeyOccMaps. +module T27013e where + +n = 0 ===================================== testsuite/tests/driver/T27013e/T27013e.stderr ===================================== @@ -0,0 +1,13 @@ +T27013e.hs:13:5: error: [GHC-49917] + Failed to load the known-names module ‘GHC.Essentials’ from the visible packages + while looking for known-occ name ‘fromInteger’ + Did you mean to use ‘-package base’? + + Could not load module ‘GHC.Essentials’. + It is a member of the hidden package ‘base-4.23.0.0’. + Use -v to see a list of the files searched for. + + To lookup known-names in scope rather than in GHC.Essentials, + use ‘-frebindable-known-names’, and import + the necessary known-names definitions from ‘ghc-internal’. + ===================================== testsuite/tests/driver/T27013e/all.T ===================================== @@ -0,0 +1 @@ +test('T27013e', normalise_version('base'), compile_fail, ['-hide-all-packages']) ===================================== testsuite/tests/driver/T27013f/T27013f.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- Counterpart to T27013a/T27013d (see #27013, !15899). +-- +-- Like the `composition` package, this module needs no known-key. +-- It is compiled with -hide-all-packages (see all.T) and WITHOUT +-- -frebindable-known-names (unlike T27013{a,d}). +-- +-- Under the default -fno-rebindable-known-names, GHC must assume +-- GHC.Essentials is an implicit dependency and tries to discover its +-- package, which fails because nothing provides it. We want a structured +-- error here (not a panic) that points at -frebindable-known-names as the +-- way to avoid forcing that dependency. See GHC.Iface.Load. +module T27013f where + +(.) :: (b -> c) -> (a -> b) -> a -> c +(f . g) x = f (g x) ===================================== testsuite/tests/driver/T27013f/T27013f.stderr ===================================== @@ -0,0 +1,13 @@ +<no location info>: error: [GHC-49917] + Failed to load the known-names module ‘GHC.Essentials’ from the visible packages + while trying to discover its package + Did you mean to use ‘-package base’? + + Could not load module ‘GHC.Essentials’. + It is a member of the hidden package ‘base-4.23.0.0’. + Use -v to see a list of the files searched for. + + This error was triggered while trying to discover the package of ‘GHC.Essentials’, + rather than when looking up any specific known-name. + If you want to enforce ‘GHC.Essentials’ is not added to the module graph implicitly, + you should use ‘-frebindable-known-names’ ===================================== testsuite/tests/driver/T27013f/all.T ===================================== @@ -0,0 +1 @@ +test('T27013f', normalise_version('base'), compile_fail, ['-hide-all-packages']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac878ff32e63933b1f4268c7005129… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac878ff32e63933b1f4268c7005129… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/issue-27105-stopTicker] FIXUP: posix ticker, fix logic when using select()
by Duncan Coutts (＠dcoutts) 12 Jun '26

12 Jun '26

Duncan Coutts pushed to branch wip/dcoutts/issue-27105-stopTicker at Glasgow Haskell Compiler / GHC Commits: 8f58e22a by Duncan Coutts at 2026-06-12T15:50:56+01:00 FIXUP: posix ticker, fix logic when using select() This is why the OSX CI was hanging, it was the only platform using select, Linux and all the BSDs were using ppoll. TODO: squash this into "posix ticker: split out ppoll/select helper functions" though actually the bug seems to be already prior to that version, so unclear how this was working. - - - - - 1 changed file: - rts/posix/Ticker.c Changes: ===================================== rts/posix/Ticker.c ===================================== @@ -317,14 +317,23 @@ static void poll_init_timeout(timeout *tv, Time t) static void poll_init_fdset(fdset *fds, int fd) { - /* select() overwrites the fdset so we must rebuild it every time. */ - FD_ZERO(&fds->selectfds); - FD_SET(fd, &fds->selectfds); + /* select() modifies the fd_set: it uses the same fd_set for reporting as + * for input. Thus we must rebuild it every time. We can optimise this + * rebuilding somewhat however if we rely on select() not modifying the + * bits that we didn't ask it to look at. So we can zero the fd_set just + * once, and then only reset the single bit for the single fd, before each + * call to selct(). + */ fds->fd = fd; + FD_ZERO(&fds->selectfds); } static int poll_no_timeout(fdset *fds) { + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); int nfds = fds->fd+1; return select(nfds, &fds->selectfds, NULL, NULL, NULL); } @@ -332,6 +341,10 @@ static int poll_no_timeout(fdset *fds) static int poll_with_timeout(fdset *fds, timeout *tv) { struct timeval tv_tmp = *tv; // copy since select may change this value. + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); int nfds = fds->fd+1; return select(nfds, &fds->selectfds, NULL, NULL, &tv_tmp); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f58e22a271d5d20b7c06d3bc903328… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f58e22a271d5d20b7c06d3bc903328… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] Minor fixes
by Adam Gundry (＠adamgundry) 12 Jun '26

12 Jun '26

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 29d1d7b2 by Adam Gundry at 2026-06-12T15:36:55+01:00 Minor fixes - - - - - 9 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Types/Evidence.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -63,6 +63,10 @@ module GHC.Core.Coercion ( applyForAllTy, decomposeFunCastCo, + mkSymTypedCastCo, + mkTransTypedCastCo, + typedCastCoercionKind, + -- ** Decomposition instNewTyCon_maybe, @@ -97,7 +101,8 @@ module GHC.Core.Coercion ( -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, tyCoVarsOfCastCo, - coercionSize, castCoercionSize, anyFreeVarsOfCo, + coercionSize, castCoercionSize, + anyFreeVarsOfCo, anyFreeVarsOfCastCo, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, @@ -123,7 +128,7 @@ module GHC.Core.Coercion ( eqCoercion, eqCoercionX, eqCastCoercion, eqCastCoercionX, -- ** Forcing evaluation of coercions - seqCo, seqCos, seqCastCoercion, + seqCo, seqCos, seqCastCoercion, seqTypedCastCoercion, -- * Pretty-printing pprCo, pprParendCo, @@ -852,15 +857,16 @@ mkFunCoNoFTF r w arg_co res_co Pair argl_ty argr_ty = coercionKind arg_co Pair resl_ty resr_ty = coercionKind res_co --- AMG TODO: more cases here, or maybe better to have a FunCo constructor of CastCoercion? -mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> Type -> CastCoercion -> Type -> CastCoercion -> CastCoercion -mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult arg_ty res_ty) (arg_cos `unionDVarSet` res_cos) -mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) res_ty res_co = ZCoercion (mkFunctionType mult arg_ty (castCoercionRKind res_ty res_co)) (arg_cos `unionDVarSet` coVarsOfCastCoDSet res_co) -mkFunCastCoNoFTF _ mult arg_ty arg_co _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty arg_co) res_ty) (res_cos `unionDVarSet` coVarsOfCastCoDSet arg_co) -mkFunCastCoNoFTF r mult _ (CCoercion arg_co) _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) -mkFunCastCoNoFTF _ _ _ ReflCastCo _ ReflCastCo = ReflCastCo -mkFunCastCoNoFTF r mult _ (CCoercion arg_co) res_ty ReflCastCo = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty)) -mkFunCastCoNoFTF r mult arg_ty ReflCastCo _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty) res_co) +-- AMG TODO: maybe better to have a FunCo constructor of CastCoercion? +mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> TypedCastCoercion -> TypedCastCoercion -> CastCoercion +mkFunCastCoNoFTF r mult (TCC arg_ty0 arg_co) (TCC res_ty0 res_co) = + case (arg_co, res_co) of + (ReflCastCo, ReflCastCo) -> ReflCastCo + (ZCoercion arg_ty1 arg_cos, _) -> ZCoercion (mkFunctionType mult arg_ty1 (castCoercionRKind res_ty0 res_co)) (arg_cos `unionDVarSet` coVarsOfCastCoDSet res_co) + (_, ZCoercion res_ty1 res_cos) -> ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty0 arg_co) res_ty1) (res_cos `unionDVarSet` coVarsOfCastCoDSet arg_co) + (CCoercion arg_co, CCoercion res_co) -> CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) + (CCoercion arg_co, ReflCastCo) -> CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty0)) + (ReflCastCo, CCoercion res_co) -> CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty0) res_co) -- | Build a function 'Coercion' from two other 'Coercion's. That is, @@ -990,8 +996,8 @@ mkForAllCo v visL visR kind_co co = mk_forall_co v visL visR kind_co co mkForAllCastCo :: HasDebugCallStack => Role -> TyCoVar -> ForAllTyFlag -> ForAllTyFlag - -> Type -> CastCoercion -> CastCoercion -mkForAllCastCo r v visL visR ty cco = case cco of + -> TypedCastCoercion -> CastCoercion +mkForAllCastCo r v visL visR (TCC ty cco) = case cco of CCoercion co -> CCoercion (mkForAllCo v visL visR MRefl co) ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visR ty) cos ReflCastCo | visL `eqForAllVis` visR -> ReflCastCo @@ -1224,6 +1230,9 @@ mkSymCastCo _ (CCoercion co) = CCoercion (mkSymCo co) mkSymCastCo ty (ZCoercion _ cos) = ZCoercion ty cos mkSymCastCo _ ReflCastCo = ReflCastCo +mkSymTypedCastCo :: TypedCastCoercion -> TypedCastCoercion +mkSymTypedCastCo (TCC ty co) = TCC (castCoercionRKind ty co) (mkSymCastCo ty co) + -- | mkTransCo creates a new 'Coercion' by composing the two -- given 'Coercion's transitively: (co1 ; co2) mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion @@ -2529,6 +2538,9 @@ seqCastCoercion (CCoercion co) = seqCo co seqCastCoercion (ZCoercion ty cos) = seqType ty `seq` seqDVarSet cos seqCastCoercion ReflCastCo = () +seqTypedCastCoercion :: TypedCastCoercion -> () +seqTypedCastCoercion (TCC ty co) = seqType ty `seq` seqCastCoercion co + seqCo :: Coercion -> () seqCo (Refl ty) = seqType ty seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco @@ -3022,3 +3034,10 @@ coToCastCo :: Coercion -> CastCoercion -- See #19815 for a bit of data and discussion on this point coToCastCo co | isReflCo co = ReflCastCo | otherwise = CCoercion co + + +typedCastCoercionKind :: TypedCastCoercion -> Pair Type +typedCastCoercionKind (TCC tyL co) = Pair (castCoercionLKind tyL co) (castCoercionRKind tyL co) + +mkTransTypedCastCo :: TypedCastCoercion -> TypedCastCoercion -> TypedCastCoercion +mkTransTypedCastCo (TCC ty1 co1) (TCC _ co2) = TCC ty1 (mkTransCastCo co1 co2) ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -4,7 +4,7 @@ module GHC.Core.Coercion.Opt ( optCoercion, optTransCo - , optCastCoercion + , optCastCoercion, optTransCastCo , OptCoercionOpts (..) ) where @@ -178,6 +178,18 @@ optTransCo opts in_scope co1 co2 | otherwise = co1 `mkTransCo` co2 +optTransCastCo :: HasDebugCallStack => OptCoercionOpts -> InScopeSet + -> TypedCastCoercion -> TypedCastCoercion -> TypedCastCoercion +optTransCastCo opts in_scope co1 co2 + | optCoercionEnabled opts + = case (co1, co2) of + (TCC ty (CCoercion co1'), TCC _ (CCoercion co2')) -> TCC ty (CCoercion (opt_trans in_scope co1' co2')) + (co1, TCC _ ReflCastCo) -> co1 + (TCC _ ReflCastCo, co2) -> co2 + _ -> co1 `mkTransTypedCastCo` co2 + | otherwise + = co1 `mkTransTypedCastCo` co2 + -- AMG TODO: not clear if coercionLKind or substTy is better choice here optCastCoercion :: OptCoercionOpts -> Subst -> TypedCastCoercion -> TypedCastCoercion optCastCoercion _ env (TCC tyL ReflCastCo) = TCC (substTy env tyL) ReflCastCo ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2702,7 +2702,6 @@ tryEtaReduce rec_ids bndrs body eval_sd where incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) - -- AMG TOOD: make this pass TypedCastCoercion so we can call ok_arg more easily? go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr -> CastCoercion -- Of type tr ~ ts @@ -2723,7 +2722,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) (exprType (App fun arg)) + | Just (co', ticks) <- ok_arg b arg (TCC (exprType (App fun arg)) co) (exprType fun) = fmap (flip (foldr mkTick) ticks) $ go bs fun co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e @@ -2795,19 +2794,18 @@ tryEtaReduce rec_ids bndrs body eval_sd --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t - -> CastCoercion -- Of kind (t1~t2) + -> TypedCastCoercion-- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied - -> Type -- Type t1 of the result (AMG TODO: use TypedCastCoercion or avoid needing to pass this?) -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type arg_ty) co fun_ty res_ty + ok_arg bndr (Type arg_ty) co fun_ty | Just tv <- getTyVar_maybe arg_ty , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of Just (Bndr _ vis, _) -> Just (fco, []) - where !fco = mkForAllCastCo Representational tv vis coreTyLamForAllTyFlag res_ty co + where !fco = mkForAllCastCo Representational tv vis coreTyLamForAllTyFlag co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) @@ -2815,24 +2813,25 @@ tryEtaReduce rec_ids bndrs body eval_sd (text "fun:" <+> ppr bndr $$ text "arg:" <+> ppr arg_ty $$ text "fun_ty:" <+> ppr fun_ty) - ok_arg bndr (Var v) co fun_ty _ + ok_arg bndr (Var v) (TCC _ co) fun_ty | bndr == v , let mult = idMult bndr , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort = Just (mkFunResCastCo Representational bndr co, []) - ok_arg bndr (Cast e co_arg) co fun_ty _ + ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (_, fun_mult, _, res_ty) <- splitFunTy_maybe fun_ty + , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) + , let co_arg' = TCC (exprType e) co_arg + = Just (mkFunCastCoNoFTF Representational fun_mult (mkSymTypedCastCo co_arg') co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co fun_ty res_ty - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty res_ty + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty = Just (co', t:ticks) - ok_arg _ _ _ _ _ = Nothing + ok_arg _ _ _ _ = Nothing {- ********************************************************************* @@ -3003,18 +3002,17 @@ pushCoValArg co old_arg_ty = funArgTy tyR pushCoercionIntoLambda - :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> Type -> CastCoercion -> Maybe (Var, CoreExpr) + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> TypedCastCoercion -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e ty co +pushCoercionIntoLambda in_scope x e co | assert (not (isTyVar x) && not (isCoVar x)) True - , let s1s2 = castCoercionLKind ty co - , let t1t2 = castCoercionRKind ty co + , Pair s1s2 t1t2 <- typedCastCoercionKind co , Just (_, _, s1, _) <- splitFunTy_maybe s1s2 , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 - , (co1, co2) <- decomposeFunCastCo co + , (co1, co2) <- decomposeFunCastCo (tccCastCoercion co) , typeHasFixedRuntimeRep t1 -- We can't push the coercion into the lambda if it would create -- a representation-polymorphic binder. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1412,6 +1412,19 @@ simplCoercion env co opts = seOptCoercionOpts env subst_only = isEmptyTvSubst subst || reSimplifying env +simplCastCoercion :: SimplEnv -> InTypedCastCoercion -> SimplM OutTypedCastCoercion +simplCastCoercion env co + = seqTypedCastCoercion opt_co `seq` return opt_co + where + -- See Note [Optimising coercions] + -- NB: substCo has a short-cut when both type and coercion substs are empty + opt_co | subst_only = substTypedCastCo subst co + | otherwise = optCastCoercion opts subst co + + subst = getTCvSubst env + opts = seOptCoercionOpts env + subst_only = isEmptyTvSubst subst || reSimplifying env + {- Note [Optimising coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some programs have very big coercions and we'd like to avoid repeatedly @@ -1440,19 +1453,6 @@ re-optimising them: -} -simplCastCoercion :: SimplEnv -> InTypedCastCoercion -> SimplM OutTypedCastCoercion -simplCastCoercion env co - = do { let opt_co | reSimplifying env = substTypedCastCo subst co - | otherwise = optCastCoercion opts subst co - -- If (reSimplifying env) is True we have already simplified - -- this coercion once, and we don't want do so again; doing - -- so repeatedly risks non-linear behaviour - -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env - ; seqCastCoercion (tccCastCoercion opt_co) `seq` return opt_co } - where - subst = getTCvSubst env - opts = seOptCoercionOpts env - ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as @@ -1861,7 +1861,7 @@ simplArg :: SimplEnvIS -- ^ Used only for its InScopeSet -- continuation passed to 'simplExprC' -> OutType -- ^ Type of the function applied to this arg -> StaticEnv -> CoreExpr -- ^ Expression with its static envt - -> OutCastCoercion -- Wrap this around the result + -> OutCastCoercion -- ^ Wrap this around the result -> SimplM OutExpr simplArg _ _ _ (Simplified {}) arg co = return $ mkCastCo arg co -- See Note [Avoid repeated simplification] ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -57,7 +57,6 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type ( Type, extendTvSubst, extendCvSubst , substTy, getTyVar_maybe ) -import GHC.Core.TyCo.FVs ( anyFreeVarsOfCastCo ) import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -29,7 +29,7 @@ import GHC.Core.Unfold.Make import GHC.Core.Make import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon -import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..) ) +import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..), optTransCastCo ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Predicate( isCoVarType ) @@ -303,11 +303,11 @@ simpleOptPgm opts this_mod binds rules = ---------------------- type SimpleClo = (SimpleOptEnv, InExpr) -data SimpleContItem = ApplyToArg SimpleClo | CastIt OutType OutCastCoercion +data SimpleContItem = ApplyToArg SimpleClo | CastIt OutTypedCastCoercion instance Outputable SimpleContItem where ppr (ApplyToArg (_, arg)) = text "ARG" <+> ppr arg - ppr (CastIt _ co) = text "CAST" <+> ppr co + ppr (CastIt co) = text "CAST" <+> ppr co data SimpleOptEnv = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts @@ -473,7 +473,7 @@ simple_app env e0@(Lam {}) as0@(_:_) where (env', b') = subst_opt_bndr env b -- See Note [Eliminate casts in function position] - do_beta env e@(Lam b _) as@(CastIt ty out_co:rest) + do_beta env e@(Lam b _) as@(CastIt out_co:rest) | isNonCoVarId b -- Optimise the inner lambda to make it an 'OutExpr', which makes it -- possible to call 'pushCoercionIntoLambda' with the 'OutCoercion' 'co'. @@ -482,7 +482,7 @@ simple_app env e0@(Lam {}) as0@(_:_) -- we need to do this to avoid mixing 'InExpr' and 'OutExpr', or two -- 'InExpr' with different environments (getting this wrong caused #26588 & #26589.) , Lam out_b out_body <- simple_app env e [] - , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body ty out_co + , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body out_co = do_beta (soeZapSubst env) (Lam b' body') rest -- soeZapSubst: we've already optimised everything (the lambda and 'rest') by now. | otherwise @@ -542,19 +542,18 @@ simple_app env (Cast e co) as simple_app env e as = rebuild_app env (simple_opt_expr env e) as --- FIXME (cast-zapping rebase): HEAD added optTransCo to further optimise the --- combined coercion when stacking. There is no optTransCastCo yet, so for now --- we use mkTransCastCo and leave the deeper optimisation as a TODO. add_cast :: SimpleOptEnv -> InTypedCastCoercion -> [SimpleContItem] -> [SimpleContItem] -add_cast env (TCC tyL co1) as - | isReflCastCo co1' +add_cast env co1 as + | isReflCastCo (tccCastCoercion co1) = as | otherwise = case as of - CastIt _ co2:rest -> CastIt ty (co1' `mkTransCastCo` co2):rest - _ -> CastIt ty co1':as + CastIt co2:rest -> CastIt (optTransCastCo opts in_scope opt_co1 co2):rest + _ -> CastIt opt_co1:as where - TCC ty co1' = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) (TCC tyL co1) + opts = so_co_opts (soe_opts env) + in_scope = soeInScope env + opt_co1 = optCastCoercion opts (soe_subst env) co1 rebuild_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleContItem] -> OutExpr @@ -563,19 +562,19 @@ rebuild_app env fun args = foldl mk_app fun args in_scope = soeInScope env mk_app out_fun = \case ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg) - CastIt _ co -> mk_cast out_fun co + CastIt co -> mk_cast out_fun co -mk_cast :: CoreExpr -> CastCoercion -> CoreExpr +mk_cast :: CoreExpr -> TypedCastCoercion -> CoreExpr -- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. -- mkCast doesn't do that because the Simplifier does (in simplCast) -- But in SimpleOpt it's nice to kill those nested casts (#18112) -mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCastCo` co2) -mk_cast (Tick t e) co = Tick t (mk_cast e co) +mk_cast (Cast e co1) (TCC _ co2) = mk_cast e (TCC (exprType e) (co1 `mkTransCastCo` co2)) +mk_cast (Tick t e) co = Tick t (mk_cast e co) mk_cast e co - | isReflexiveCastCo (TCC (exprType e) co) + | isReflexiveCastCo co = e | otherwise - = Cast e co + = Cast e (tccCastCoercion co) {- Note [Desugaring unlifted newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1853,7 +1852,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) , assert (not $ x `elemVarSet` tyCoVarsOfCastCo co) True - , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e (exprType casted_e) co + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e (TCC (exprType casted_e) co) , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) res ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -205,11 +205,6 @@ in GHC.Tc.Solver. Yuk. This is not pretty. * * ********************************************************************* -} -tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet -tyCoVarsOfCastCo (CCoercion co) = coVarsOfCo co -tyCoVarsOfCastCo (ZCoercion ty cos) = tyCoVarsOfType ty `unionVarSet` dVarSetToVarSet cos -tyCoVarsOfCastCo ReflCastCo = emptyVarSet - tyCoVarsOfType :: Type -> TyCoVarSet -- The "deep" TyCoVars of the the type tyCoVarsOfType ty = runTyCoVars (deepTypeFV ty) @@ -227,6 +222,9 @@ tyCoVarsOfCo :: Coercion -> TyCoVarSet -- See Note [Computing deep free variables] tyCoVarsOfCo co = runTyCoVars (deepCoFV co) +tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet +tyCoVarsOfCastCo co = runTyCoVars (deepCastCoFV co) + tyCoVarsOfMCo :: MCoercion -> TyCoVarSet tyCoVarsOfMCo MRefl = emptyVarSet tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co @@ -264,7 +262,8 @@ deepTypeFV :: Type -> TyCoFV deepTypesFV :: [Type] -> TyCoFV deepCoFV :: Coercion -> TyCoFV deepCosFV :: [Coercion] -> TyCoFV -(deepTypeFV, deepTypesFV, deepCoFV, deepCosFV, _) = foldTyCo deepTcvFolder +deepCastCoFV :: CastCoercion -> TyCoFV +(deepTypeFV, deepTypesFV, deepCoFV, deepCosFV, deepCastCoFV) = foldTyCo deepTcvFolder deepTcvFolder :: TyCoFolder TyCoFV -- It's important that we use a one-shot EndoOS, to ensure that all @@ -908,10 +907,8 @@ anyFreeVarsOfCo check_fv co = DM.getAny (runFVTop (f co)) where (_, _, f, _, _) = foldTyCo (afvFolder check_fv) anyFreeVarsOfCastCo :: (TyCoVar -> Bool) -> CastCoercion -> Bool -anyFreeVarsOfCastCo check_fv (CCoercion co) = anyFreeVarsOfCo check_fv co -anyFreeVarsOfCastCo check_fv (ZCoercion ty cvs) = - anyFreeVarsOfType check_fv ty || anyDVarSet check_fv cvs -anyFreeVarsOfCastCo _ ReflCastCo = False +anyFreeVarsOfCastCo check_fv co = DM.getAny (runFVTop (f co)) + where (_, _, _, _, f) = foldTyCo (afvFolder check_fv) noFreeVarsOfType :: Type -> Bool noFreeVarsOfType ty = not $ DM.getAny (runFVTop (f ty)) ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1058,6 +1058,9 @@ instance Outputable Coercion where instance Outputable CastCoercion where ppr = pprCastCo +instance Outputable TypedCastCoercion where + ppr (TCC ty co) = text "TCC" <> parens (ppr ty <> text "," <+> ppr co) + instance Outputable CoSel where ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r) ppr SelForAll = text "All" ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -636,7 +636,7 @@ optSubTypeHsWrapper wrap not_in v (WpCompose w1 w2) = not_in v w1 && not_in v w2 not_in v (WpEvApp (EvExpr e)) = not (v `elemVarSet` exprFreeVars e) not_in v (WpEvApp (EvCastExpr e co ty)) = not (v `elemVarSet` exprFreeVars e) - && not_in_cast_co v co + && not (anyFreeVarsOfCastCo (== v) co) && not (anyFreeVarsOfType (== v) ty) not_in _ (WpEvApp (EvTypeable {})) = False -- Giving up; conservative not_in _ (WpEvApp (EvFun {})) = False -- Giving up; conservative @@ -644,13 +644,6 @@ optSubTypeHsWrapper wrap not_in _ (WpEvLam {}) = False -- Ditto not_in _ (WpLet {}) = False -- Ditto - not_in_cast_co :: TyVar -> CastCoercion -> Bool - not_in_cast_co v = \case - CCoercion co -> not (anyFreeVarsOfCo (== v) co) - ZCoercion ty cvs -> not (anyFreeVarsOfType (== v) ty) - && not (v `elemDVarSet` cvs) - ReflCastCo -> True - not_in_submult :: TyVar -> SubMultCo -> Bool not_in_submult v = \case EqMultCo co -> not (anyFreeVarsOfCo (== v) co) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29d1d7b24d49795cb561066c4954255… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29d1d7b24d49795cb561066c4954255… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] hadrian: include haddock theme files in cross-compiler bindist lib dir
by Sven Tennie (＠supersven) 12 Jun '26

12 Jun '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 3da57cb4 by Sven Tennie at 2026-06-12T13:01:38+00:00 hadrian: include haddock theme files in cross-compiler bindist lib dir The haddock builder is hardcoded to Stage1 (Builder.hs), so haddock HTML/latex theme files are only populated in _build/stage1/lib/html/. Cross-compiler bindists use library_stage = Stage2, so their lib dir (_build/stage2/lib/) never gets these files, and the installed cross-compiler's haddock fails with: haddock: internal error: .../lib/html: does not exist Fix: need the haddock resource files for library_stage before copying the lib dir into the bindist. The copy rules in Generate.hs already map _build/stageN/lib/html/** from utils/haddock/haddock-api/resources for all stages; they just need to be triggered. - - - - - 1 changed file: - hadrian/src/Rules/BinaryDist.hs Changes: ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -214,6 +214,12 @@ buildBinDistDir root conf@BindistConfig{..} = do IO.removeFile versioned_runhaskell_path <|> return () IO.createFileLink version_prog versioned_runhaskell_path + -- The haddock builder hardcodes Stage1 for its resource files (Builder.hs), + -- so for cross bindists (library_stage /= Stage1) the html/latex theme dirs + -- are not populated in the library_stage lib dir. + when (library_stage /= Stage1) $ + need =<< haddockDeps library_stage + copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir -- Regenerate settings file without LibDir. For bindists, LibDir should View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3da57cb4c840e1027de1bb9b3edd4af… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3da57cb4c840e1027de1bb9b3edd4af… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: haddock: render modules concurrently
by Marge Bot (＠marge-bot) 12 Jun '26

12 Jun '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8965cb76 by Marc Scholten at 2026-06-12T04:53:22-04:00 haddock: render modules concurrently - - - - - 8cc0b64a by Duncan Coutts at 2026-06-12T04:54:06-04:00 Promote HAVE_PREEMPTION from Timer.c to OSThreads.h We will want to know about HAVE_PREEMPTION in more places. HAVE_PREEMPTION tells us that we do have OS threads available, irrespective of whether THREADED is defined. In particular, HAVE_PREEMPTION is defined on all proper OSs, but not on WASM (and hyopthetically may not be true on some other platforms like micro-controllers, RTOSs, VM hypervisors etc). - - - - - cce574ed by Duncan Coutts at 2026-06-12T04:54:06-04:00 Define ACQUIRE_LOCK_ALWAYS and friends Fix issue #27335 Like the atomic _ALWAYS variants, these lock actions are always defined, rather than being dependent on whether we are in the THREADED case. All the "normal" LOCK macros are defined to be no-ops when !THREADED. The use case for the _ALWAYS variants is where we are using OS threads even in the non-threaded RTS. This includes everything to do with the timer/ticker thread, which is used in the non-threaded RTS too. In particular, we will want to use this for eventlog things, because the timer thread performs eventlogging concurrently with the main capability, even in the non-threaded RTS. - - - - - 1f28d1f6 by Duncan Coutts at 2026-06-12T04:54:06-04:00 Use ACQUIRE/RELEASE_LOCK_ALWAYS with eventBufMutex Even in the non-threaded RTS the eventBufMutex is needed by both the main capability and the timer/ticker thread, so always use the mutex. This should fix #25165 which is about the main capability and the timer thread posting events to the eventlog buffer concurrently and thereby corrupting the buffer data. - - - - - 0ff29782 by Duncan Coutts at 2026-06-12T04:54:06-04:00 Expose eventBufMutex in the EventLog interface/header We will need it in forkProcess to ensure we don't write to the global eventlog buffer concurrently with trying to flush eventlog buffers and do the fork(). - - - - - 7a688395 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Split flushAllCapsEventsBufs into safe and unlocked version Following the convention that unlocked versions have a trailing _ underscore in their name. This one requires the caller to hold the eventlog global buffer mutex. We will need this in forkProcess. - - - - - 341ed474 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Remove redundant use of stopTimer in setNumCapabilities Historically, the comment here was: We must stop the interval timer while we are changing the capabilities array lest handle_tick may try to context switch an old capability. See #17289. and We must disable the timer while we do this since the tick handler may call contextSwitchAllCapabilities, which may see the capabilities array as we free it. What this refers to is that historically, when changing the number of capabilities, the array of capabilities was reallocated to a new size, allocating new ones and freeing the old ones, thus invalidating all existing capbility pointers. Strangely, for good measure the code used to call stopTimer twice (hence the two similar comments above). However, since commit a3eccf06292dd666b24606251a52da2b466a9612, the capabilities array is no longer reallocated. Instead the array is allcoated once on RTS startup to the maximum size it could ever be allowed to be, and then capabilities get enabled/disabled at runtime. So the capability pointers never become invalid anymore. At worst, they may point to capabilities that are disabled. Thus we no longer need to stop the timer (twice) while we change the number of enabled capabilities. This also partially solves issue #27105, which notes that stopTimer is being used as if it were synchronous, when it is not. At least for this case, the solution is that stopTimer is not needed at all! - - - - - 674858e3 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Remove redundant use of stopTimer in forkProcess but replace it with taking the eventlog buffer lock during the fork. Fixes issue #27105 The original reason to block the timer during a fork was that historically the timer was implemented using a periodic timer signal, and the signal itself would interrupt the fork system call (returning EINTR). For large processes (where fork() takes a while) this could permanently livelock: the timer always would go off before the fork could complete, which got retried in a loop forever. The timer is no longer implemented as a unix signal, but uses threads. Thus the original problem no longer exists. The only remaining reason to block the timer tick is to prevent actions taken by the tick from interfering with the delicate process involved in fork (taking a load of locks and pausing everything). The only thing we need to do is to prevent the eventlog from being written to or flushed while the fork is taking place. To achieve this all we need to do is hold the mutex for the global eventlog buffer. This removes the last use of stopTimer that expects stopTimer to work synchronously (which it was not) and thus solves issue #27105. To be clear, we solve issue #27105 not by making stopTimer synchronous, but by eliminating the use sites that expected it to be synchronous. - - - - - 982359f1 by sheaf at 2026-06-12T09:04:02-04:00 Add type family performance test for #26426 Some GHC versions produced large numbers of coercions after typechecking and desugaring when compiling the program in #26426: Version | Typechecker time | Typechecker allocations | Coercions -------:|-----------------:|------------------------:|---------: 9.6 | 47 ms | 48 MB | 110k 9.8 | 1000 ms | 486 MB | 10,437k 9.10 | 922 ms | 489 MB | 10,436k 9.12 | 906 ms | 482 MB | 10,437k 9.14 | 63 ms | 55 MB | 333k 10.0 | 47 ms | 64 MB | 35k The improvement 9.12 -> 9.14 was due to commit 22d11fa818fae2c95c494fc0fac1f8cb4c6e7cb6, while the improvement 9.14 -> 10.0 was due to commit 0b7df6db9e46df40e86fbff1a66dc10440b99db5. As the behaviour of GHC seems better than it's ever been on this program, we declare victory, adding this performance test to ensure we don't regress on this program. On the way, we update Note [Combining equalities] in GHC.Tc.SolveR.Equality with the explanation of the 9.12 -> 9.14 improvement (getting rid of an exponential blowup in coercion sizes), and we update Note [Exploiting closed type families] in GHC.Tc.Solver.FunDeps with the explanation of the 9.14 -> 10.0 improvement (bringing down coercion size growth from cubic to quadratic). - - - - - 396d6f0e by Zubin Duggal at 2026-06-12T09:04:02-04:00 compiler: mark tool messages as errors/warnings depending on the exit code Fixes #27370 - - - - - 23 changed files: - + changelog.d/tool-messages-27370 - compiler/GHC/SysTools/Process.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - rts/Capability.c - rts/Schedule.c - rts/Timer.c - rts/eventlog/EventLog.c - rts/eventlog/EventLog.h - rts/include/rts/OSThreads.h - + testsuite/tests/driver/T27370/Makefile - + testsuite/tests/driver/T27370/T27370.hs - + testsuite/tests/driver/T27370/T27370.pp - + testsuite/tests/driver/T27370/T27370.stderr - + testsuite/tests/driver/T27370/all.T - + testsuite/tests/perf/compiler/T26426.hs - testsuite/tests/perf/compiler/all.T - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Options.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs Changes: ===================================== changelog.d/tool-messages-27370 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Mark messages from external tools as errors or warnings depending on + the tool's exit code. Previously, output printed to stderr by tools was + unconditionally reported as errors. +issues: #27370 +mrs: !16170 ===================================== compiler/GHC/SysTools/Process.hs ===================================== @@ -26,8 +26,9 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.CliOption -import GHC.Driver.Errors (reportError) +import GHC.Driver.Errors (reportDiagnostic) +import GHC.Types.Error ( DiagnosticReason(..) ) import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString @@ -271,9 +272,10 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea getLocaleEncoding >>= hSetEncoding readEnd hSetNewlineMode readEnd nativeNewlineMode hSetBuffering readEnd LineBuffering - messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd - mapM_ processBuildMessage messages - waitForProcess hProcess + messages <- parseBuildMessages . filter_fn . lines <$> hGetContents' readEnd + code <- waitForProcess hProcess + mapM_ (processBuildMessage code) messages + return code hClose hStdIn case r of Left (SomeException e) -> do @@ -282,13 +284,16 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea Right s -> do return s where - processBuildMessage :: BuildMessage -> IO () - processBuildMessage msg = do + processBuildMessage :: ExitCode -> BuildMessage -> IO () + processBuildMessage code msg = do case msg of BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg BuildError loc msg -> do - reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg + let reason = case code of + ExitSuccess -> WarningWithoutFlag + ExitFailure{} -> ErrorWithoutFlag + reportDiagnostic logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) reason msg parseBuildMessages :: [String] -> [BuildMessage] parseBuildMessages str = loop str Nothing ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2980,15 +2980,30 @@ But it's not so simple: we kick out g1. Now we have two constraints [W] g1 : F a ~ a Int (arising from (F a ~ a Int)) [W] g2{rw:g1} : F a ~ a Int (arising from (F alpha ~ F a)) - If we end up with g2 in the inert set (not g1) we'll get a very confusing - error message that we can solve (F a ~ a Int) - arising from F a ~ F a + If we solve `g1` from `g2` we end up with + g1 := g2 + [W] g2{} : F a ~ a Int (arising from (F alpha ~ F a)) + and hence (since alpha := a) we report that we can't solve (F a ~ a Int) + arising from (F a ~ F a), which is extremely confusing. Moreover, it seems + wrong to "solve" `g1` using `g2` when `g2` has itself been rewritten by `g1`! TL;DR: Better to hang on to `g1` (with no rewriters), in preference to `g2` (which has a rewriter). See (WRW11) in Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint. + + Note that the decision to prefer a constraint without rewriters over one that + has rewriters can also have a /huge/ effect on performance. For instance, it + avoids an **exponential** blow-up in the size of coercions produced when + typechecking in T26426. In that program, we have coercions of the form: + + co_i :: TaggedTypes as `Append` TaggedTypes '[ty] + ~# TaggedTypes (as `Append` '[ty]) + + and each 'co_{i+1}' contains the previous 'co_i' twice. Without preferring + Wanteds with no rewriters, we essentially end up inlining 'co_i' into 'co_{i+1}', + which results in exponentially-sized proof terms, growing like O(2^i). -} tryInertEqs :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -1198,6 +1198,56 @@ Key point: equations that are not relevant do not need to be considered for fund and [W] I alpha ~ Int |> g2 Here we definiteily want to take advantage of injectivity. +(CF6) This machinery can also have a significant positive effect on the size of + proof terms. For example (simplification of T26426): + + type family (++) a b where { '[] ++ ys = ys; (x:xs) ++ ys = x : (xs ++ ys) } + type family MapId a where { MapId '[] = '[]; MapId (x:xs) = x : MapId xs } + + app :: (MapId xs ++ MapId ys ~ MapId (xs ++ ys)) => Proxy xs -> Proxy ys -> Proxy (xs ++ ys) + + test :: Proxy [ty_1, ..., ty_n] + test = Proxy @'[ty_1] + `app` Proxy @'[ty_2] + ... + `app` Proxy @'[ty_n] + + Every `app` call gives rise to a Wanted of the form: + + [W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i]) + + while the overall result type gives us a Wanted of the form + + [W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n] + + By using (CFFA) on this result Wanted, we deduce that we must have + + acc_n ~ [ty_1, ..., ty_{n-1}] + + which is a flat list. Repeating the process, (CFFA) allows us to deduce that + + acc_i ~ [ty_1, ..., ty_{i-1}] + + for all i. This allows the other Wanteds to be solved directly, giving rise to + proof terms with the typical triangular O(n^2) shape + + co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1}) + ; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i])) + + However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left + as the nested application: + + acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}]) + + This means that 'MapId acc_i' is stuck until we reduce the above, which takes + O(i^2) type family reduction steps, instead of O(i). The same applies to + the other proof term involving 'MapId (acc_i ++ '[ty_i])'. + Consequently, without (CFFA) the overall coercion size blows up to O(n^3). + + The takeaway is that (CFFA) allows us to push in the (flat) result type, + instead of relying on recursively built sub-proof terms, which brings down + coercion sizes (in certain situations) from O(n^3) to O(n^2). + Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in ===================================== rts/Capability.c ===================================== @@ -443,13 +443,6 @@ void moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS) { #if defined(THREADED_RTS) - // We must disable the timer while we do this since the tick handler may - // call contextSwitchAllCapabilities, which may see the capabilities array - // as we free it. The alternative would be to protect the capabilities - // array with a lock but this seems more expensive than necessary. - // See #17289. - stopTimer(); - if (to == 1) { // THREADED_RTS must work on builds that don't have a mutable // BaseReg (eg. unregisterised), so in this case @@ -470,8 +463,6 @@ moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS) } debugTrace(DEBUG_sched, "allocated %d more capabilities", to - from); - - startTimer(); #endif } ===================================== rts/Schedule.c ===================================== @@ -37,6 +37,7 @@ #include "win32/AsyncWinIO.h" #endif #include "Trace.h" +#include "eventlog/EventLog.h" #include "RaiseAsync.h" #include "Threads.h" #include "Timer.h" @@ -2100,24 +2101,31 @@ forkProcess(HsStablePtr *entry ACQUIRE_LOCK(&all_tasks_mutex); #endif - stopTimer(); // See #4074 - #if defined(TRACING) - flushAllCapsEventsBufs(); // so that child won't inherit dirty file buffers +#if defined(HAVE_PREEMPTION) + // We must hold the eventlog global mutex over the fork to prevent the + // timer thread from trying to post events. While holding the mutex we need + // to flush the eventlogs (global and per-cap) so that child won't inherit + // dirty eventlog buffers or file buffers. + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); +#endif + flushAllCapsEventsBufs_(); #endif pid = fork(); if (pid) { // parent - startTimer(); // #4074 - RELEASE_LOCK(&sched_mutex); RELEASE_LOCK(&sm_mutex); RELEASE_LOCK(&stable_ptr_mutex); RELEASE_LOCK(&stable_name_mutex); RELEASE_LOCK(&task->lock); +#if defined(TRACING) && defined(HAVE_PREEMPTION) + RELEASE_LOCK_ALWAYS(&eventBufMutex); +#endif + #if defined(THREADED_RTS) /* N.B. releaseCapability_ below may need to take all_tasks_mutex */ RELEASE_LOCK(&all_tasks_mutex); @@ -2303,12 +2311,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) cap = rts_lock(); task = cap->running_task; - - // N.B. We must stop the interval timer while we are changing the - // capabilities array lest handle_tick may try to context switch - // an old capability. See #17289. - stopTimer(); - stopAllCapabilities(&cap, task); if (new_n_capabilities < enabled_capabilities) @@ -2364,9 +2366,7 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) tracingAddCapabilities(n_capabilities, new_n_capabilities); #endif - // Resize the capabilities array - // NB. after this, capabilities points somewhere new. Any pointers - // of type (Capability *) are now invalid. + // Allocate and initialise the extra capabilities moreCapabilities(n_capabilities, new_n_capabilities); // Resize and update storage manager data structures @@ -2394,8 +2394,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) // Notify IO manager that the number of capabilities has changed. notifyIOManagerCapabilitiesChanged(&cap); - startTimer(); - rts_unlock(cap); #endif // THREADED_RTS ===================================== rts/Timer.c ===================================== @@ -28,11 +28,6 @@ #include "RtsSignals.h" #include "rts/EventLogWriter.h" -// See Note [No timer on wasm32] -#if !defined(wasm32_HOST_ARCH) -#define HAVE_PREEMPTION -#endif - // This global counter is used to allow multiple threads to stop the // timer temporarily with a stopTimer()/startTimer() pair. If // timer_enabled == 0 timer is enabled ===================================== rts/eventlog/EventLog.c ===================================== @@ -129,8 +129,11 @@ typedef struct _EventsBuf { static EventsBuf *capEventBuf; // one EventsBuf for each Capability static EventsBuf eventBuf; // an EventsBuf not associated with any Capability -#if defined(THREADED_RTS) -static Mutex eventBufMutex; // protected by this mutex +#if defined(HAVE_PREEMPTION) +// Note that this mutex is used even in the non-threaded RTS, since the timer +// thread posts events and flushes. So _all_ uses of this mutex must use +// ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS. +Mutex eventBufMutex; // protects eventBuf above #endif // Event type @@ -393,8 +396,10 @@ initEventLogging(void) moreCapEventBufs(0, get_n_capabilities()); initEventsBuf(&eventBuf, EVENT_LOG_SIZE, (EventCapNo)(-1)); -#if defined(THREADED_RTS) +#if defined(HAVE_PREEMPTION) initMutex(&eventBufMutex); +#endif +#if defined(THREADED_RTS) initMutex(&state_change_mutex); #endif } @@ -416,7 +421,7 @@ startEventLogging_(void) { initEventLogWriter(); - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postHeaderEvents(); /* @@ -425,7 +430,7 @@ startEventLogging_(void) */ printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return true; } @@ -495,7 +500,7 @@ endEventLogging(void) flushEventLog_(NULL); - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); // Mark end of events (data). postEventTypeNum(&eventBuf, EVENT_DATA_END); @@ -503,7 +508,7 @@ endEventLogging(void) // Flush the end of data marker. printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); stopEventLogWriter(); event_log_writer = NULL; @@ -666,7 +671,7 @@ void postCapEvent (EventTypeNum tag, EventCapNo capno) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); @@ -685,14 +690,14 @@ postCapEvent (EventTypeNum tag, barf("postCapEvent: unknown event tag %d", tag); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetEvent (EventTypeNum tag, EventCapsetID capset, StgWord info) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); @@ -726,7 +731,7 @@ void postCapsetEvent (EventTypeNum tag, barf("postCapsetEvent: unknown event tag %d", tag); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetStrEvent (EventTypeNum tag, @@ -740,14 +745,14 @@ void postCapsetStrEvent (EventTypeNum tag, return; } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); if (!hasRoomForVariableEvent(&eventBuf, size)){ printAndClearEventBuf(&eventBuf); if (!hasRoomForVariableEvent(&eventBuf, size)){ errorBelch("Event size exceeds buffer size, bail out"); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return; } } @@ -758,7 +763,7 @@ void postCapsetStrEvent (EventTypeNum tag, postBuf(&eventBuf, (StgWord8*) msg, strsize); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetVecEvent (EventTypeNum tag, @@ -783,14 +788,14 @@ void postCapsetVecEvent (EventTypeNum tag, } } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); if (!hasRoomForVariableEvent(&eventBuf, size)){ printAndClearEventBuf(&eventBuf); if(!hasRoomForVariableEvent(&eventBuf, size)){ errorBelch("Event size exceeds buffer size, bail out"); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return; } } @@ -804,7 +809,7 @@ void postCapsetVecEvent (EventTypeNum tag, postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i])); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postWallClockTime (EventCapsetID capset) @@ -813,7 +818,7 @@ void postWallClockTime (EventCapsetID capset) StgWord64 sec; StgWord32 nsec; - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); /* The EVENT_WALL_CLOCK_TIME event is intended to allow programs reading the eventlog to match up the event timestamps with wall @@ -846,7 +851,7 @@ void postWallClockTime (EventCapsetID capset) postWord64(&eventBuf, sec); postWord32(&eventBuf, nsec); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } /* @@ -885,7 +890,7 @@ void postEventHeapInfo (EventCapsetID heap_capset, W_ mblockSize, W_ blockSize) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_INFO_GHC); postEventHeader(&eventBuf, EVENT_HEAP_INFO_GHC); @@ -899,7 +904,7 @@ void postEventHeapInfo (EventCapsetID heap_capset, postWord64(&eventBuf, mblockSize); postWord64(&eventBuf, blockSize); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postEventGcStats (Capability *cap, @@ -952,7 +957,7 @@ void postTaskCreateEvent (EventTaskId taskId, EventCapNo capno, EventKernelThreadId tid) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_CREATE); postEventHeader(&eventBuf, EVENT_TASK_CREATE); @@ -961,14 +966,14 @@ void postTaskCreateEvent (EventTaskId taskId, postCapNo(&eventBuf, capno); postKernelThreadId(&eventBuf, tid); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postTaskMigrateEvent (EventTaskId taskId, EventCapNo capno, EventCapNo new_capno) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_MIGRATE); postEventHeader(&eventBuf, EVENT_TASK_MIGRATE); @@ -977,28 +982,28 @@ void postTaskMigrateEvent (EventTaskId taskId, postCapNo(&eventBuf, capno); postCapNo(&eventBuf, new_capno); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postTaskDeleteEvent (EventTaskId taskId) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_DELETE); postEventHeader(&eventBuf, EVENT_TASK_DELETE); /* EVENT_TASK_DELETE (taskID) */ postTaskId(&eventBuf, taskId); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postEventNoCap (EventTypeNum tag) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void @@ -1042,9 +1047,9 @@ void postLogMsg(EventsBuf *eb, EventTypeNum type, char *msg, va_list ap) void postMsg(char *msg, va_list ap) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postLogMsg(&eventBuf, EVENT_LOG_MSG, msg, ap); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapMsg(Capability *cap, char *msg, va_list ap) @@ -1138,32 +1143,32 @@ void postConcUpdRemSetFlush(Capability *cap) void postConcMarkEnd(StgWord32 marked_obj_count) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_CONC_MARK_END); postEventHeader(&eventBuf, EVENT_CONC_MARK_END); postWord32(&eventBuf, marked_obj_count); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postNonmovingHeapCensus(uint16_t blk_size, const struct NonmovingAllocCensus *census) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_NONMOVING_HEAP_CENSUS); postWord16(&eventBuf, blk_size); postWord32(&eventBuf, census->n_active_segs); postWord32(&eventBuf, census->n_filled_segs); postWord32(&eventBuf, census->n_live_blocks); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_NONMOVING_PRUNED_SEGMENTS); postWord32(&eventBuf, pruned_segments); postWord32(&eventBuf, free_segments); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void closeBlockMarker (EventsBuf *ebuf) @@ -1224,7 +1229,7 @@ static HeapProfBreakdown getHeapProfBreakdown(void) void postHeapProfBegin(void) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); PROFILING_FLAGS *flags = &RtsFlags.ProfFlags; StgWord modSelector_len = flags->modSelector ? strlen(flags->modSelector) : 0; @@ -1258,42 +1263,42 @@ void postHeapProfBegin(void) postStringLen(&eventBuf, flags->ccsSelector, ccsSelector_len); postStringLen(&eventBuf, flags->retainerSelector, retainerSelector_len); postStringLen(&eventBuf, flags->bioSelector, bioSelector_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleBegin(StgInt era) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN); postWord64(&eventBuf, era); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapBioProfSampleBegin(StgInt era, StgWord64 time) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN); postEventHeader(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN); postWord64(&eventBuf, era); postWord64(&eventBuf, time); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleEnd(StgInt era) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END); postWord64(&eventBuf, era); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleString(const char *label, StgWord64 residency) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord label_len = strlen(label); StgWord len = 1+8+label_len+1; CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); @@ -1303,7 +1308,7 @@ void postHeapProfSampleString(const char *label, postWord8(&eventBuf, 0); postWord64(&eventBuf, residency); postStringLen(&eventBuf, label, label_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #if defined(PROFILING) @@ -1313,7 +1318,7 @@ void postHeapProfCostCentre(StgWord32 ccID, const char *srcloc, StgBool is_caf) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord label_len = strlen(label); StgWord module_len = strlen(module); StgWord srcloc_len = strlen(srcloc); @@ -1326,13 +1331,13 @@ void postHeapProfCostCentre(StgWord32 ccID, postStringLen(&eventBuf, module, module_len); postStringLen(&eventBuf, srcloc, srcloc_len); postWord8(&eventBuf, is_caf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleCostCentre(CostCentreStack *stack, StgWord64 residency) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord depth = 0; CostCentreStack *ccs; for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) @@ -1351,7 +1356,7 @@ void postHeapProfSampleCostCentre(CostCentreStack *stack, depth>0 && ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack, depth--) postWord32(&eventBuf, ccs->cc->ccID); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } @@ -1359,7 +1364,7 @@ void postProfSampleCostCentre(Capability *cap, CostCentreStack *stack, StgWord64 tick) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord depth = 0; CostCentreStack *ccs; for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) @@ -1377,7 +1382,7 @@ void postProfSampleCostCentre(Capability *cap, depth>0 && ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack, depth--) postWord32(&eventBuf, ccs->cc->ccID); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } // This event is output at the start of profiling so the tick interval can @@ -1385,11 +1390,11 @@ void postProfSampleCostCentre(Capability *cap, // can be calculated from how many samples there are. void postProfBegin(void) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_PROF_BEGIN); // The interval that each tick was sampled, in nanoseconds postWord64(&eventBuf, TimeToNS(RtsFlags.MiscFlags.tickInterval)); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #endif /* PROFILING */ @@ -1415,11 +1420,11 @@ static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) void postTickyCounterDefs(StgEntCounter *counters) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); for (StgEntCounter *p = counters; p != NULL; p = p->link) { postTickyCounterDef(&eventBuf, p); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p) @@ -1443,13 +1448,13 @@ static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p) void postTickyCounterSamples(StgEntCounter *counters) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TICKY_COUNTER_SAMPLE); postEventHeader(&eventBuf, EVENT_TICKY_COUNTER_BEGIN_SAMPLE); for (StgEntCounter *p = counters; p != NULL; p = p->link) { postTickyCounterSample(&eventBuf, p); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #endif /* TICKY_TICKY */ void postIPE(const InfoProvEnt *ipe) @@ -1459,7 +1464,7 @@ void postIPE(const InfoProvEnt *ipe) // See Note [Maximum event length]. const StgWord MAX_IPE_STRING_LEN = 65535; - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord table_name_len = MIN(strlen(ipe->prov.table_name), MAX_IPE_STRING_LEN); StgWord closure_desc_len = MIN(strlen(closure_desc_buf), MAX_IPE_STRING_LEN); StgWord ty_desc_len = MIN(strlen(ipe->prov.ty_desc), MAX_IPE_STRING_LEN); @@ -1489,7 +1494,7 @@ void postIPE(const InfoProvEnt *ipe) postBuf(&eventBuf, &colon, 1); postStringLen(&eventBuf, ipe->prov.src_span, src_span_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void printAndClearEventBuf (EventsBuf *ebuf) @@ -1601,14 +1606,21 @@ void flushLocalEventsBuf(Capability *cap) // Flush all capabilities' event buffers when we already hold all capabilities. // Used during forkProcess. void flushAllCapsEventsBufs(void) +{ + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); + flushAllCapsEventsBufs_(); + RELEASE_LOCK_ALWAYS(&eventBufMutex); +} + +// Unsafe version that does not acquire/release eventBufMutex. You must +// hold the eventBufMutex, which you must acquire with ACQUIRE_LOCK_ALWAYS! +void flushAllCapsEventsBufs_(void) { if (!event_log_writer) { return; } - ACQUIRE_LOCK(&eventBufMutex); printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); for (unsigned int i=0; i < getNumCapabilities(); i++) { flushLocalEventsBuf(getCapability(i)); @@ -1641,9 +1653,9 @@ static void flushEventLog_(Capability **cap USED_IF_THREADS) return; } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); #if defined(THREADED_RTS) Task *task = newBoundTask(); ===================================== rts/eventlog/EventLog.h ===================================== @@ -18,6 +18,13 @@ #if defined(TRACING) extern bool eventlog_enabled; +#if defined(HAVE_PREEMPTION) +// Avoid using this mutex directly if at all possible. It is needed in the +// implementation of forkProcess. +// +// All uses of this mutex must use ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS. +extern Mutex eventBufMutex; +#endif void initEventLogging(void); void restartEventLogging(void); @@ -27,6 +34,7 @@ void abortEventLogging(void); // #4512 - after fork child needs to abort void moreCapEventBufs (uint32_t from, uint32_t to); void flushLocalEventsBuf(Capability *cap); void flushAllCapsEventsBufs(void); +void flushAllCapsEventsBufs_(void); void flushAllEventsBufs(Capability *cap); typedef void (*EventlogInitPost)(void); ===================================== rts/include/rts/OSThreads.h ===================================== @@ -14,6 +14,46 @@ #pragma once +/* Note [Threads and preemption] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + All full-fat OSs that GHC works on have OS threads, and we use them even in + the non-threaded RTS for a few features: + * Haskell thread preemption; + * sample-based profiling; + * idle GC; + * periodic eventlog flushing. + + We use defined(HAVE_PREEMPTION) to decide if these features are implemented + via OS threads. + + On platforms like WASM/js we do not have OS threads in any conventional + sense, and the features above are either not available or are implemented + differently. See Note [No timer on wasm32]. + + In future if GHC is ported to platforms like bare-metal micro-controllers, + RTOSs or to run directly under hypervisors then such platforms may also not + have threads available and they should not define HAVE_PREEMPTION here. Or + for some micro-controller RTOSs like Zeypher one may have a choice about + whether to use threads or not (at a size cost). Here would be the right + place to control whether the feature list above is supported. + */ +#if defined(wasm32_HOST_ARCH) + // See Note [No timer on wasm32] + // To confuse matters, WASM _does_ have pthread.h but it doesnt work. +#elif defined(HAVE_PTHREAD_H) || defined(HAVE_WINDOWS_H) +#define HAVE_PREEMPTION +#else +#error Decide if this platform has threads and pre-emption or not. +#endif +// And JS does all of this differently, without using this bit of the RTS. + +// Configuration sanity check +#if defined(THREADED_RTS) && !defined(HAVE_PREEMPTION) +//TODO we would like to be able to assert this: +// #error Configuration error: THREADED_RTS should imply HAVE_PREEMPTION +// however at the moment we cannot due to issue #27346. +#endif + #if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS) #if defined(CMINUSMINUS) @@ -210,9 +250,29 @@ extern bool timedWaitCondition ( Condition* pCond, Mutex* pMut, Time timeout) // // Mutexes // +// Even in the non-threaded RTS we use threads and mutexes! In particular the +// timer/ticker is implemented using a thread. And using threads needs locks. +// In particular we need locks for the data shared between the timer/ticker +// thread and the thread running the main capability. +#if defined(HAVE_PREEMPTION) extern void initMutex ( Mutex* pMut ); extern void closeMutex ( Mutex* pMut ); +// The "always" variants do locking in the threaded and non-threaded RTS. +// The normal variants below are no-ops in the non-threaded RTS. +#define ACQUIRE_LOCK_ALWAYS(l) OS_ACQUIRE_LOCK(l) +#define TRY_ACQUIRE_LOCK_ALWAYS(l) OS_TRY_ACQUIRE_LOCK(l) +#define RELEASE_LOCK_ALWAYS(l) OS_RELEASE_LOCK(l) +#define ASSERT_LOCK_HELD_ALWAYS(l) OS_ASSERT_LOCK_HELD(l) +#else +// And just to be a bit confusing, the always variants are still no-ops when we +// do not HAVE_PREEMPTION, since then we don't have threads or mutexes at all. +#define ACQUIRE_LOCK_ALWAYS(l) +#define TRY_ACQUIRE_LOCK_ALWAYS(l) 0 +#define RELEASE_LOCK_ALWAYS(l) +#define ASSERT_LOCK_HELD_ALWAYS(l) +#endif + // Processors and affinity void setThreadAffinity (uint32_t n, uint32_t m); void setThreadNode (uint32_t node); @@ -228,6 +288,7 @@ void releaseThreadNode (void); #else +// No-ops in the non-threaded RTS. See also the _ALWAYS variants above. #define ACQUIRE_LOCK(l) #define TRY_ACQUIRE_LOCK(l) 0 #define RELEASE_LOCK(l) ===================================== testsuite/tests/driver/T27370/Makefile ===================================== @@ -0,0 +1,7 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T27370: + chmod +x ./T27370.pp + '$(TEST_HC)' $(TEST_HC_OPTS) -c T27370.hs ===================================== testsuite/tests/driver/T27370/T27370.hs ===================================== @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF ./T27370.pp #-} +module T27370 where ===================================== testsuite/tests/driver/T27370/T27370.pp ===================================== @@ -0,0 +1,5 @@ +#!/bin/sh +cp "$2" "$3" +echo "$1:2:8: a located warning from an external tool" +echo " with a continuation line" +echo "an unlocated line from an external tool" ===================================== testsuite/tests/driver/T27370/T27370.stderr ===================================== @@ -0,0 +1,5 @@ +T27370.hs:2:8: warning: + a located warning from an external tool + with a continuation line + +an unlocated line from an external tool ===================================== testsuite/tests/driver/T27370/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27370', + [extra_files(['T27370.hs', 'T27370.pp']), + when(opsys('mingw32'), skip)], + makefile_test, ['T27370']) ===================================== testsuite/tests/perf/compiler/T26426.hs ===================================== @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +module T26426 ( + someTypes +) where + +import Data.Kind (Type) +import GHC.TypeLits (Symbol) + +type family Append (left :: [k]) (right :: [k]) :: [k] where + Append '[] right = right + Append (a : rest) right = a : Append rest right + +type family TaggedTypes (tags :: [(Symbol, Type)]) :: [Type] where + TaggedTypes '[] = '[] + TaggedTypes ('(_, typ) : rest) = typ : TaggedTypes rest + +data Types (types :: [(Symbol, Type)]) = Types + +mkTypes :: forall sym val. val -> Types '[ '(sym, val) ] +mkTypes _ = Types + +appendTypes :: + -- This constraint is the one that causes the issue. If the next line is commented + -- out, then this module compiles quickly + Append (TaggedTypes left) (TaggedTypes right) ~ TaggedTypes (Append left right) => + Types left -> Types right -> Types (Append left right) +appendTypes _ _ = Types + +someTypes :: + Types + [ '("01", Int) + , '("02", Int) + , '("03", Int) + , '("04", Int) + , '("05", Int) + , '("06", Int) + , '("07", Int) + , '("08", Int) + , '("09", Int) + , '("10", Int) + , '("11", Int) + , '("12", Int) + , '("13", Int) + , '("14", Int) + , '("15", Int) + , '("16", Int) + ] + +someTypes = + mkTypes @"01" 1 `appendTypes` + mkTypes @"02" 2 `appendTypes` + mkTypes @"03" 3 `appendTypes` + mkTypes @"04" 4 `appendTypes` + mkTypes @"05" 5 `appendTypes` + mkTypes @"06" 6 `appendTypes` + mkTypes @"07" 7 `appendTypes` + mkTypes @"08" 8 `appendTypes` + mkTypes @"09" 9 `appendTypes` + mkTypes @"10" 10 `appendTypes` + mkTypes @"11" 11 `appendTypes` + mkTypes @"12" 12 `appendTypes` + mkTypes @"13" 13 `appendTypes` + mkTypes @"14" 14 `appendTypes` + mkTypes @"15" 15 `appendTypes` + mkTypes @"16" 16 ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -87,6 +87,13 @@ test('T783', ], compile,['']) +test ('T26426' + , [ only_ways(['normal']) + , collect_compiler_stats('bytes allocated',4) ] + , compile + , [''] + ) + test('T5321Fun', [ only_ways(['normal']), # no optimisation for this one collect_compiler_runtime(2), ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -97,6 +97,7 @@ library , filepath , ghc-boot , mtl + , semaphore-compat , transformers , text ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -29,6 +29,7 @@ module Haddock ( withGhc ) where +import Control.Concurrent.MVar (modifyMVar, modifyMVar_, newMVar) import Control.DeepSeq (force) import Control.Monad hiding (forM_) import Control.Monad.IO.Class (MonadIO(..)) @@ -41,6 +42,7 @@ import Data.Maybe import Data.IORef import Data.Map.Strict (Map) import Data.Version (makeVersion) +import GHC.Conc (getNumProcessors) import GHC.Parser.Lexer (ParserOpts) import qualified GHC.Driver.Config.Parser as Parser import qualified Data.Map.Strict as Map @@ -84,11 +86,55 @@ import Haddock.Options import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Haddock.Compat (getProcessID) +import System.Semaphore (AbstractSem(..), openSemaphore, releaseSemaphoreToken, waitOnSemaphore) -------------------------------------------------------------------------------- -- * Exception handling -------------------------------------------------------------------------------- +concSemChoiceFromFlags :: [Flag] -> Maybe (Either FilePath (Maybe Int)) +concSemChoiceFromFlags = + List.foldl' step Nothing + where + step _ (Flag_ParCount n) = Just (Right n) + step _ (Flag_ParSemaphore sem) = Just (Left sem) + step acc _ = acc + +-- | Build the render concurrency semaphore selected by Haddock's parallelism flags. +-- Without an explicit flag, render sequentially; @-j@ uses the host processor +-- count, @-jN@ uses a local bounded semaphore, and @-jsem@ joins the external +-- semaphore used for GHC jobserver coordination. +concSemFromChoice :: Maybe (Either FilePath (Maybe Int)) -> IO AbstractSem +concSemFromChoice choice = + case choice of + Nothing -> newBoundedSem 1 + Just (Right Nothing) -> newBoundedSem =<< getNumProcessors + Just (Right (Just n)) -> newBoundedSem n + Just (Left semName) -> do + openSemaphore semName >>= \case + Left err -> throwIO err + Right sem -> do + tokens <- newMVar [] + pure + AbstractSem + { acquireSem = mask $ \restore -> do + token <- restore (waitOnSemaphore sem) + modifyMVar_ tokens $ \held -> pure (token : held) + , releaseSem = mask_ $ do + token <- modifyMVar tokens $ \case + [] -> pure ([], Nothing) + heldToken : heldTokens -> pure (heldTokens, Just heldToken) + forM_ token releaseSemaphoreToken + } + +injectParFlags :: Maybe (Either FilePath (Maybe Int)) -> [Flag] -> [Flag] +injectParFlags choice flags = + case choice of + Nothing -> flags + Just (Right Nothing) -> Flag_OptGhc "-j" : flags + Just (Right (Just n)) -> Flag_OptGhc ("-j" ++ show n) : flags + Just (Left sem) -> Flag_OptGhc "-jsem" : Flag_OptGhc sem : flags + handleTopExceptions :: IO a -> IO a handleTopExceptions = @@ -177,11 +223,12 @@ haddockWithGhc ghc args = handleTopExceptions $ do Just "YES" | not noCompilation -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags - -- Inject `-j` into ghc options, if given to Haddock - flags' <- pure $ case optParCount flags'' of - Nothing -> flags'' - Just Nothing -> Flag_OptGhc "-j" : flags'' - Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags'' + let parChoice = concSemChoiceFromFlags flags'' + + -- Inject parallelism flags into ghc options, if given to Haddock + flags' <- pure $ injectParFlags parChoice flags'' + + concSem <- concSemFromChoice parChoice -- Whether or not to bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags @@ -238,7 +285,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -251,7 +298,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages [] + liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -311,10 +358,11 @@ renderStep -> [Flag] -> SinceQual -> QualOption + -> AbstractSem -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do +renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -330,7 +378,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -348,11 +396,12 @@ render -> [Flag] -> SinceQual -> QualOption + -> AbstractSem -> [Interface] -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do +render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -516,7 +565,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url opt_contents_url opt_index_url unicode sincePkg packageInfo - qual pretty withQuickjump + qual pretty concSem withQuickjump return () unless (withBaseURL || isJust (optOneShot flags)) $ do copyHtmlBits odir libDir themes withQuickjump @@ -555,7 +604,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming logger "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} - ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty srcMap ifaces + ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty concSem srcMap ifaces return () @@ -842,4 +891,3 @@ getPrologue parserOpts flags = rightOrThrowE :: Either String b -> IO b rightOrThrowE (Left msg) = throwE msg rightOrThrowE (Right x) = pure x - ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -31,7 +31,8 @@ import Haddock.Backends.Hyperlinker.Utils import Haddock.Backends.Xhtml.Utils (renderToBuilder) import Haddock.InterfaceFile import Haddock.Types -import Haddock.Utils (Verbosity, out, verbose) +import Haddock.Utils (Verbosity, out, verbose, mapConcurrentlyWith_) +import System.Semaphore (AbstractSem) import qualified Data.ByteString.Builder as Builder -- | Generate hyperlinked source for given interfaces. @@ -51,19 +52,21 @@ ppHyperlinkedSource -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> AbstractSem + -- ^ Concurrency semaphore for module renders -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty srcs' ifaces = do +ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty concSem srcs' ifaces = do createDirectoryIfMissing True srcdir unless isOneShot $ do let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir </> srcCssFile copyFile (libdir </> "html" </> highlightScript) $ srcdir </> highlightScript - mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces + mapConcurrentlyWith_ concSem (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir </> hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -69,6 +69,7 @@ import Haddock.ModuleTree import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Utils +import System.Semaphore (AbstractSem) import Haddock.Utils.Json import Haddock.Version @@ -115,6 +116,8 @@ ppHtml -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> AbstractSem + -- ^ Concurrency semaphore for module renders -> Bool -- ^ Also write Quickjump index -> IO () @@ -138,6 +141,7 @@ ppHtml packageInfo qual debug + concSem withQuickjump = do let visible_ifaces = filter visible ifaces @@ -192,7 +196,7 @@ ppHtml visible_ifaces [] - mapM_ + mapConcurrentlyWith_ concSem ( ppHtmlModule odir doctitle ===================================== utils/haddock/haddock-api/src/Haddock/Options.hs ===================================== @@ -29,6 +29,7 @@ module Haddock.Options , wikiUrls , baseUrl , optParCount + , optParSemaphore , optDumpInterfaceFile , optShowInterfaceFile , optLaTeXStyle @@ -48,7 +49,7 @@ module Haddock.Options import Control.Applicative import qualified Data.Char as Char -import Data.List (dropWhileEnd) +import Data.List (dropWhileEnd, isPrefixOf) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -122,6 +123,7 @@ data Flag | Flag_SinceQualification String | Flag_IgnoreLinkSymbol String | Flag_ParCount (Maybe Int) + | Flag_ParSemaphore FilePath | Flag_TraceArgs | Flag_OneShot String | Flag_NoCompilation @@ -406,6 +408,11 @@ options backwardsCompat = [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n") "load modules in parallel" + , Option + [] + ["jsem"] + (ReqArg Flag_ParSemaphore "SEM") + "use semaphore SEM to limit parallelism" , Option [] ["trace-args"] @@ -423,7 +430,7 @@ getUsage = do parseHaddockOpts :: [String] -> IO ([Flag], [String]) parseHaddockOpts params = - case getOpt Permute (options True) params of + case getOpt Permute (options True) (normalizeJsemArgs params) of (flags, args, []) -> return (flags, args) (_, _, errors) -> do usage <- getUsage @@ -498,6 +505,18 @@ optMathjax flags = optLast [str | Flag_Mathjax str <- flags] optParCount :: [Flag] -> Maybe (Maybe Int) optParCount flags = optLast [n | Flag_ParCount n <- flags] +optParSemaphore :: [Flag] -> Maybe FilePath +optParSemaphore flags = optLast [s | Flag_ParSemaphore s <- flags] + +normalizeJsemArgs :: [String] -> [String] +normalizeJsemArgs = map rewrite + where + rewrite arg + | arg == "-jsem" = "--jsem" + | "-jsem=" `isPrefixOf` arg = "--jsem=" ++ drop 6 arg + | "-jsem" `isPrefixOf` arg = "--jsem=" ++ drop 5 arg + | otherwise = arg + qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [str | Flag_Qualification str <- flags] of ===================================== utils/haddock/haddock-api/src/Haddock/Utils.hs ===================================== @@ -54,6 +54,10 @@ module Haddock.Utils , replace , spanWith + -- * Concurrency utilities + , mapConcurrentlyWith_ + , newBoundedSem + -- * Logging , parseVerbosity , Verbosity (..) @@ -86,6 +90,13 @@ import Haddock.Types import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as LText +import Control.Concurrent (forkFinally) +import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (throwIO) +import Control.Monad (void) +import System.Semaphore (AbstractSem (..)) + -------------------------------------------------------------------------------- -- * Logging @@ -334,6 +345,43 @@ html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) html_xrefs' :: Map ModuleName FilePath html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') +-- * Concurrency utilities + +-------------------------------------------------------------------------------- + +mapConcurrentlyWith_ :: AbstractSem -> (a -> IO ()) -> [a] -> IO () +mapConcurrentlyWith_ _ _ [] = return () +mapConcurrentlyWith_ concSem f xs = do + -- Create MVars to wait for completion and collect results + resultMVars <- mapM (const newEmptyMVar) xs + + -- Fork a thread for each element + mapM_ (forkThread concSem) (zip xs resultMVars) + + -- Wait for all threads and collect any errors + results <- mapM takeMVar resultMVars + + -- Re-throw the first exception if any + case [err | Left err <- results] of + (err:_) -> throwIO err + [] -> return () + where + forkThread concSem' (x, resultMVar) = do + acquireSem concSem' + void $ forkFinally (f x) $ \res -> do + releaseSem concSem' + putMVar resultMVar res + +newBoundedSem :: Int -> IO AbstractSem +newBoundedSem maxThreads = do + sem <- newQSem (max 1 maxThreads) + pure + AbstractSem + { acquireSem = waitQSem sem + , releaseSem = signalQSem sem + } + + ----------------------------------------------------------------------------- -- * List utils View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faf06ab1239bd275658e8a0d0b1b1f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faf06ab1239bd275658e8a0d0b1b1f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/issue-27105-stopTicker] 39 commits: fix typo : compete with performance, not complete
by Duncan Coutts (＠dcoutts) 12 Jun '26

12 Jun '26

Duncan Coutts pushed to branch wip/dcoutts/issue-27105-stopTicker at Glasgow Haskell Compiler / GHC Commits: f2f5c6ba by Nikita Efremov at 2026-06-02T16:04:54+00:00 fix typo : compete with performance, not complete - - - - - 5524ea0e by Wolfgang Jeltsch at 2026-06-03T08:01:26-04:00 Make the current `base` buildable with GHC 9.14 This comprises the following changes: * Disable some imports into `GHC.Base` for GHC 9.14 * Disable some imports into `Prelude` for GHC 9.14 * Disable separate `ArrowLoop` import for GHC 9.14 * Disable `GHC.Internal.STM` import for GHC 9.14 * Disable `GHC.Internal.Unicode.Version` import for GHC 9.14 * Disable `GHC.Internal.TH.Monad` import for GHC 9.14 * Add alternative `fixIO` import for GHC 9.14 * Add alternative `unsafeCodeCoerce` import for GHC 9.14 * Disable hiding of imported SIMD operations for GHC 9.14 * Disable use of GHC 9.14’s `printToHandleFinalizerExceptionHandler` * Enable use of `getFileHash` from `ghc-internal` for GHC 9.14 * Make `thenA` available for GHC 9.14 * Make `thenM` available for GHC 9.14 * Disable translation of `IoManagerFlagPoll` for GHC 9.14 * Add `hGetNewlineMode` for GHC 9.14 - - - - - d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00 Fix #27067 - Clarify haddocks on `minusNaturalMaybe` - - - - - f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00 Avoid mkTick in Core Prep breaking ANF As discovered in #27182, mkTick can break ANF. This patch introduces a variant of mkTick that skips the single optimisation that could break ANF. This is preferrable over switching to the raw Tick constructor, as the latter may introduce spurious cost centres in profiling reports. This is a temporary measure until we more thoroughly refactor how mkTick works (see #27141). See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. Fixes #27182 - - - - - cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00 clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements" - - - - - a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 498bb21a by David Eichmann at 2026-06-09T18:02:39-04:00 Hadrian: avoid response files when command line is short enough This replaces the logic of always using response files on Windows. With the new condition based on command line lenght, reponse files can be avoided in many more cases (on windows). Now that response files are only used in a small number of cases, response files are always kept and the -r / --keep-response-files command line options have been removed The response file paths are nolonger randomized. They are placed in the `_build/rsp` directory. This ensures they are ignored by git and we that Hadrian reuses response file paths when rebuilding rather than leaving stale response files around. Update user guide putting response files in its own section - - - - - 87f510a5 by Simon Hengel at 2026-06-09T18:03:25-04:00 Don't use non-breaking spaces - - - - - 41a19379 by David Eichmann at 2026-06-09T18:04:11-04:00 Hadrian: remove unused wrapper scripts from windows bindist These wrapper scripts are only installed on non-relocatable builds which are not generally supported on windows. - - - - - ce01ccb6 by sheaf at 2026-06-10T05:08:48-04:00 Don't drop ticks around variables of type `IO ()` GHC.Core.Utils.mkTick is responsible for placing a tick on a Core expression. It contains logic for dropping SCCs (non-counting profiling ticks) around non-function variables, as such variables cannot meaningfully contribute to profiles. However, the logic for what counts as a function was incorrect: it used `isFunTy` which returns 'False' for types such as 'IO ()' where the function arrow is hidden under a newtype. We now use 'mightBeFunTy' instead of 'isFunTy'. This ensures we don't drop ticks in cases we aren't sure. On the way, we improve the documentation of 'isFunTy', 'isPiTy' and 'mightBeFunTy', and update the latter's implementation to consistently handle unary classes. Fixes #27225 ------------------------- Metric Decrease: T5642 ------------------------- - - - - - d311c4f1 by Simon Jakobi at 2026-06-10T05:09:32-04:00 testsuite: Add regression test for #4081 Check that a strict constructor field is unboxed once outside an enclosing loop, not re-inspected each iteration (the float-out case-floating from 9cb20b488). Uses simonpj's `data T a = T !a` example from the ticket; T4081.stderr captures the expected Core. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 333df444 by sheaf at 2026-06-10T05:10:25-04:00 Check for cabal-install >= 3.12 upfront Starting with commit 8cb99552f607f6bc4000e45ab32532d50c8bb996, Hadrian requires cabal-install >= 3.12 in order to use the 'cabal path' command that was introduced in version 3.12, as per https://github.com/haskell/cabal/blob/a51c4ee1556d816ad86e90db7e6330dd51b0b… This was not reflected in the Hadrian build script, causing a delayed build failure instead of enforcing the version requirement upfront, which this patch does. Fixes #27317 - - - - - 98c20394 by sheaf at 2026-06-10T05:11:09-04:00 Fix crash in Data.Data instance for HsCtxt The Data.Data instance for HsCtxt contained an error for the 'toConstr' method, which could trigger for example when looking at -ddump-tc-ast traces. Replace it with the 'abstractConstr' pattern used in the rest of the codebase. - - - - - 5ac9ce7d by Zubin Duggal at 2026-06-10T21:26:32+05:30 hadrian: Remove old package.conf files when generating new ones Old package.conf files might exists with different hashes, causing issues like #26661 Fixes #26661 - - - - - c9015f09 by sheaf at 2026-06-11T12:40:28-04:00 Fix AArch64 clobbering bug for MUL2 On AArch64, the code generator could clobber one of the input operands when computing the lower bits of a MUL2 operation. This rendered invalid the subsequent computation of the high bits. This commit fixes that by using a temporary register. The register allocator can remove the redundant move in the common case when the registers do not conflict. Fixes #27046 - - - - - 7ab90288 by Rodrigo Mesquita at 2026-06-11T12:41:11-04:00 fix: make T27131 less flaky It seems that T27131 fails flakily in a race where we check the flag before the capability had the chance to process the mailbox which sets the flag. This seemingly should only happen if the capability ends up being the same for setting and checking the flag. - - - - - 8965cb76 by Marc Scholten at 2026-06-12T04:53:22-04:00 haddock: render modules concurrently - - - - - 8cc0b64a by Duncan Coutts at 2026-06-12T04:54:06-04:00 Promote HAVE_PREEMPTION from Timer.c to OSThreads.h We will want to know about HAVE_PREEMPTION in more places. HAVE_PREEMPTION tells us that we do have OS threads available, irrespective of whether THREADED is defined. In particular, HAVE_PREEMPTION is defined on all proper OSs, but not on WASM (and hyopthetically may not be true on some other platforms like micro-controllers, RTOSs, VM hypervisors etc). - - - - - cce574ed by Duncan Coutts at 2026-06-12T04:54:06-04:00 Define ACQUIRE_LOCK_ALWAYS and friends Fix issue #27335 Like the atomic _ALWAYS variants, these lock actions are always defined, rather than being dependent on whether we are in the THREADED case. All the "normal" LOCK macros are defined to be no-ops when !THREADED. The use case for the _ALWAYS variants is where we are using OS threads even in the non-threaded RTS. This includes everything to do with the timer/ticker thread, which is used in the non-threaded RTS too. In particular, we will want to use this for eventlog things, because the timer thread performs eventlogging concurrently with the main capability, even in the non-threaded RTS. - - - - - 1f28d1f6 by Duncan Coutts at 2026-06-12T04:54:06-04:00 Use ACQUIRE/RELEASE_LOCK_ALWAYS with eventBufMutex Even in the non-threaded RTS the eventBufMutex is needed by both the main capability and the timer/ticker thread, so always use the mutex. This should fix #25165 which is about the main capability and the timer thread posting events to the eventlog buffer concurrently and thereby corrupting the buffer data. - - - - - 0ff29782 by Duncan Coutts at 2026-06-12T04:54:06-04:00 Expose eventBufMutex in the EventLog interface/header We will need it in forkProcess to ensure we don't write to the global eventlog buffer concurrently with trying to flush eventlog buffers and do the fork(). - - - - - 7a688395 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Split flushAllCapsEventsBufs into safe and unlocked version Following the convention that unlocked versions have a trailing _ underscore in their name. This one requires the caller to hold the eventlog global buffer mutex. We will need this in forkProcess. - - - - - 341ed474 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Remove redundant use of stopTimer in setNumCapabilities Historically, the comment here was: We must stop the interval timer while we are changing the capabilities array lest handle_tick may try to context switch an old capability. See #17289. and We must disable the timer while we do this since the tick handler may call contextSwitchAllCapabilities, which may see the capabilities array as we free it. What this refers to is that historically, when changing the number of capabilities, the array of capabilities was reallocated to a new size, allocating new ones and freeing the old ones, thus invalidating all existing capbility pointers. Strangely, for good measure the code used to call stopTimer twice (hence the two similar comments above). However, since commit a3eccf06292dd666b24606251a52da2b466a9612, the capabilities array is no longer reallocated. Instead the array is allcoated once on RTS startup to the maximum size it could ever be allowed to be, and then capabilities get enabled/disabled at runtime. So the capability pointers never become invalid anymore. At worst, they may point to capabilities that are disabled. Thus we no longer need to stop the timer (twice) while we change the number of enabled capabilities. This also partially solves issue #27105, which notes that stopTimer is being used as if it were synchronous, when it is not. At least for this case, the solution is that stopTimer is not needed at all! - - - - - 674858e3 by Duncan Coutts at 2026-06-12T04:54:07-04:00 Remove redundant use of stopTimer in forkProcess but replace it with taking the eventlog buffer lock during the fork. Fixes issue #27105 The original reason to block the timer during a fork was that historically the timer was implemented using a periodic timer signal, and the signal itself would interrupt the fork system call (returning EINTR). For large processes (where fork() takes a while) this could permanently livelock: the timer always would go off before the fork could complete, which got retried in a loop forever. The timer is no longer implemented as a unix signal, but uses threads. Thus the original problem no longer exists. The only remaining reason to block the timer tick is to prevent actions taken by the tick from interfering with the delicate process involved in fork (taking a load of locks and pausing everything). The only thing we need to do is to prevent the eventlog from being written to or flushed while the fork is taking place. To achieve this all we need to do is hold the mutex for the global eventlog buffer. This removes the last use of stopTimer that expects stopTimer to work synchronously (which it was not) and thus solves issue #27105. To be clear, we solve issue #27105 not by making stopTimer synchronous, but by eliminating the use sites that expected it to be synchronous. - - - - - eb64f6fa by Duncan Coutts at 2026-06-12T13:37:09+01:00 Add a test for thread scheduler fairness It also tests that the interval timer and context switching works. We also test that fairness is lost when the context switching interval is too coarse for the duration of the test. We add this test before doing surgery on the interval timer, so we have decent coverage. - - - - - b98680f0 by Duncan Coutts at 2026-06-12T13:37:09+01:00 Make exported stop/startTimer no-ops, and rename internal functions Specifically, internally rename: stop/startTimer to pause/unpauseTimer stop/startTicker to pause/unpauseTicker and keep stop/startTimer as exported functions, but now as no-ops. In the past the stop/startTicker actions were used incorrectly as if they were synchronous, which they are not. See issue #27105. We now document pause/unpackTicker as being async and not to be used for the purpose of concurrency safety. The existing stop/startTimer (note Timer not Ticker, the Timer calls the Ticker!) are also exported from the RTS as a public API. This was historically because the ticker used signals and it was important to suspend the timer signel over a process fork. So these functions were exported to be used by the process and unix libraries. We cannot just remove the RTS exports, but we now make them no-ops, and they can be removed from the process and unix library later. This was already documented in a changelog.d entry no-more-timer-signal but due to changes during the MR process the change to make stop/startTicker into no-ops didn't make it into the earlier MR. - - - - - c09e823b by Duncan Coutts at 2026-06-12T13:37:09+01:00 Make exitTicker/exitTimer unconditionally synchronous We never use them asynchronously, and we should never need to do so. And update some related comments. - - - - - 1d60852d by Duncan Coutts at 2026-06-12T13:37:09+01:00 posix ticker: update and improve comments on (un)pause and exit Clarify what is async vs sync. - - - - - 66997f76 by Duncan Coutts at 2026-06-12T13:37:09+01:00 posix ticker: split out ppoll/select helper functions Move the #ifdefs out of the main code body by introducing local helper functions and types, which themselves have two implementations (with a common API) based on ppoll or select. This helps improve clarity/readability. - - - - - 7e2fcac6 by Duncan Coutts at 2026-06-12T13:37:09+01:00 posix ticker: improve the implementation The existing implementation supported pausing and exiting, with the implementation of pausing reling on a mutex and condition variable. It needed to check the pause and stop shared variables on every iteration. It relies on ppoll or select, to wait on the timeout and also wait on an interrupt fd. The interrupt fd was only used for prompt exit/shutdown, and not for pausing or other notification. The pause only needed a lock and a memory operation, but the pause was not prompt. The resume used a lock, and signaling a cond var. The new implementation uses a somewhat more regular design: every notification is done by setting a shared variable and interrupting/notifying the ticker via the fd. The ticker thread does not need to check any shared variables on normal timer expiry, only when it recevies notification. This may be a micro-optimisation, but the tick occurs 100 times a second by default so any improvements in the hot path are amplified. When the ticker thread does receive notification it can check the various shared variables and update its local state. The blocking relies on using ppoll/select but without a timeout. This avoids the condition var and also allows further notifications when paused (also used for unpausing). This design can be extended with further notification types if needed by using and checking further shared vars (or making existing shared vars an enum or counter). This may be used in future for additional notifications to the ticker thread. This will likely be used to proxy wakeUpRts from a single handler context for example. And this approach, avoiding mutexes, is compatible with use from signal handlers. So overall, it's: * slightly simpler / more regular; * easier to extend with additional notifications; * probably slightly more efficient (but a micro-optimisation); * and supports calling notification from signal handlers - - - - - 6946dcf2 by Duncan Coutts at 2026-06-12T13:37:09+01:00 posix ticker: further minor local renaming for code clarity Improve the clarity with better choice of names for several local vars and function. - - - - - 1c934fcf by Duncan Coutts at 2026-06-12T13:37:09+01:00 win32 ticker: split out local helper functions - - - - - 78bf1a58 by Duncan Coutts at 2026-06-12T13:37:09+01:00 win32 ticker: provide guarantee about concurrency and idempotency Use a lock to ensure pause/unpause can be used concurrently. Use a paused variable, protected by the lock, to ensure that pause and unpause are both idempotent. This is what the portable API expects. - - - - - 89b61c10 by Duncan Coutts at 2026-06-12T13:37:09+01:00 win32 ticker: make the initial tick be after one wait interval There is no need to tick immediately. This is consistent with the posix implementation. - - - - - f78dd0e2 by Duncan Coutts at 2026-06-12T13:37:09+01:00 ticker: remove now-unnecessary layer of enable/disable There was an atomic variable used to block *part* of the actions of the tick handler. This still did not make stopTimer synchronous, even for the part of the the handle_tick actions it covered. It also added a more expensive (sequentuially consistent) atomic operation in the hot path for the handle_tick action, whereas our new design requires no atomic ops at all. Now that we have eliminate the need for synchronous stop/startTicker, we don't need this not-quite-working-anyway atomic protocol. The new pause/unpauseTicker is explicitly asynchronous and idempotent. - - - - - 4d8afd3b by Duncan Coutts at 2026-06-12T13:37:09+01:00 ticker: add TODOs about issue #27250: too much being done from handle_tick The handle_tick should not perform I/O, block, perform long-running operations or call arbitrary user code. Unfortunately, everything to do with the eventlog (at the moment) falls into all those categories. - - - - - 95 changed files: - boot - + changelog.d/T27046 - + changelog.d/T27182.md - + changelog.d/T27225 - + changelog.d/T27317 - + changelog.d/T27359 - changelog.d/hadrian-response-files.md - + changelog.d/hadrian-stale-package-confs-26661 - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/javascript.rst - docs/users_guide/using.rst - hadrian/build-cabal - hadrian/src/Builder.hs - hadrian/src/CommandLine.hs - hadrian/src/Hadrian/Builder/Ar.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Rules/BinaryDist.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Arrow.hs - libraries/base/src/Control/Monad.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Conc.hs - libraries/base/src/GHC/Conc/Sync.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Unicode.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/Mem/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/Natural.hs - rts/Capability.c - rts/RtsStartup.c - rts/Schedule.c - rts/Ticker.h - rts/Timer.c - rts/Timer.h - rts/eventlog/EventLog.c - rts/eventlog/EventLog.h - rts/include/rts/OSThreads.h - rts/include/rts/Timer.h - rts/posix/Ticker.c - rts/win32/Ticker.c - testsuite/driver/runtests.py - testsuite/mk/test.mk - + testsuite/tests/codeGen/should_run/T27046.hs - + testsuite/tests/codeGen/should_run/T27046_cmm.cmm - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/concurrent/should_run/T27105.hs - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/profiling/should_run/T27225.hs - + testsuite/tests/profiling/should_run/T27225.stdout - + testsuite/tests/profiling/should_run/T27225b.hs - + testsuite/tests/profiling/should_run/T27225b.stdout - testsuite/tests/profiling/should_run/all.T - testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/profiling/should_run/scc001.prof.sample - testsuite/tests/rts/T27131.hs - testsuite/tests/rts/T27131.stdout - + testsuite/tests/simplCore/should_compile/T4081.hs - + testsuite/tests/simplCore/should_compile/T4081.stderr - testsuite/tests/simplCore/should_compile/all.T - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Options.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dd42dae73599ee3097174ec5fb1d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dd42dae73599ee3097174ec5fb1d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/optCoercion-repro
by Simon Jakobi (＠sjakobi2) 12 Jun '26

12 Jun '26

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

1 0

[Git][ghc/ghc][wip/fendor/drop-preloadclosure-from-unitstate] Drop `preloadClosure` from `UnitState`
by Hannes Siebenhandl (＠fendor) 12 Jun '26

12 Jun '26

Hannes Siebenhandl pushed to branch wip/fendor/drop-preloadclosure-from-unitstate at Glasgow Haskell Compiler / GHC Commits: 43abe5dc by fendor at 2026-06-12T14:10:49+02:00 Drop `preloadClosure` from `UnitState` It is always hard-coded to the same value. Backpack Unit instantiation isn't using it any more. Allows us to simplify the API and get rid of `improveUnit`. - - - - - 7 changed files: - + changelog.d/T27308 - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs Changes: ===================================== changelog.d/T27308 ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Drop `preloadClosure` from `UnitState` +issues: #27308 +mrs: !16108 + +description: { + Drop `preloadClosure` from `UnitState` as it is always set to the empty set. + This allows to simplify the `UnitState` and related functions. +} + ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -241,7 +241,6 @@ withBkpSession cid insts deps session_type do_this = do -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> let uid = unwireUnit unit_state - $ improveUnit unit_state $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage (showSDoc dflags @@ -310,19 +309,16 @@ buildUnit session cid insts lunit = do -- The compilation dependencies are just the appropriately filled -- in unit IDs which must be compiled before we can compile. let hsubst = listToUFM insts - deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps + deps = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps -- Build dependencies OR make sure they make sense. BUT NOTE, -- we can only check the ones that are fully filled; the rest -- we have to defer until we've typechecked our local signature. -- TODO: work this into GHC.Driver.Make!! - forM_ (zip [1..] deps0) $ \(i, dep) -> + forM_ (zip [1..] deps) $ \(i, dep) -> case session of TcSession -> return () - _ -> compileInclude (length deps0) (i, dep) - - -- IMPROVE IT - let deps = map (improveUnit (hsc_units hsc_env)) deps0 + _ -> compileInclude (length deps) (i, dep) mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -914,13 +914,13 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do && not (isOneShot (ghcMode dflags)) then return (Failed (HomeModError mod loc)) else do - r <- read_file hooks logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) + r <- read_file hooks logger name_cache dflags wanted_mod (ml_hi_file loc) case r of Failed err -> return (Failed $ BadIfaceFile err) Succeeded (iface,_fp) -> do - r2 <- load_dynamic_too_maybe hooks logger name_cache unit_state + r2 <- load_dynamic_too_maybe hooks logger name_cache (setDynamicNow dflags) wanted_mod iface loc case r2 of @@ -936,20 +936,20 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too_maybe hooks logger name_cache unit_state dflags wanted_mod iface loc +load_dynamic_too_maybe hooks logger name_cache dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) - | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc + | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc = do - read_file hooks logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case +load_dynamic_too hooks logger name_cache dflags wanted_mod iface loc = do + read_file hooks logger name_cache dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash iface == mi_mod_hash dynIface -> return (Succeeded ()) @@ -963,10 +963,10 @@ load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc -read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +read_file :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) -read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do +read_file hooks logger name_cache dflags wanted_mod file_path = do -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -975,7 +975,7 @@ read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do case getModuleInstantiation wanted_mod of (_, Nothing) -> wanted_mod (_, Just indef_mod) -> - instModuleToModule unit_state + instModuleToModule (uninstantiateInstantiatedModule indef_mod) read_result <- readIface hooks logger dflags name_cache wanted_mod' file_path case read_result of ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -620,7 +620,7 @@ checkMergedSignatures hsc_env mod_summary self_recomp = do new_merged = case lookupUniqMap (requirementContext unit_state) (ms_mod_name mod_summary) of Nothing -> [] - Just r -> sort $ map (instModuleToModule unit_state) r + Just r -> sort $ map instModuleToModule r if old_merged == new_merged then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) else return $ needsRecompileBecause SigsMergeChanged ===================================== compiler/GHC/Unit.hs ===================================== @@ -226,8 +226,8 @@ on-the-fly: A 'VirtUnit' may be indefinite or definite, it depends on whether some holes remain in the instantiated unit OR in the instantiating units (recursively). Having a fully instantiated (i.e. definite) virtual unit can lead to some issues -if there is a matching compiled unit in the preload closure. See Note [VirtUnit -to RealUnit improvement] +if there is a matching compiled unit in the preload closure. +See Note [VirtUnit to RealUnit improvement] Unit database and indefinite units ---------------------------------- @@ -314,7 +314,6 @@ field in the SDocContext to pretty-print. (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a UnitId), that's what will be shown to the user so it's no big deal. - Note [VirtUnit to RealUnit improvement] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -332,6 +331,8 @@ same type-checking session, their names won't match (e.g. "abc:M.X" vs As we want them to match we just replace the virtual unit with the installed one: for some reason this is called "improvement". +HISTORICAL: + There is one last niggle: improvement based on the unit database means that we might end up developing on a unit that is not transitively depended upon by the units the user specified directly via command line @@ -340,6 +341,12 @@ instantiations are out of date. The solution is to only improve a unit id if the new unit id is part of the 'preloadClosure'; i.e., the closure of all the units which were explicitly specified. +NOTE: + +The 'preloadClosure' was completely unused, thus we removed it without +changing any of the tests. It doesn't seem to be necessary any more. +It is unclear at which exact point this became redundant. + Note [Representation of module/name variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -7,7 +7,6 @@ module GHC.Unit.State ( -- * Reading the package config, and processing cmdline args UnitState(..), - PreloadUnitClosure, UnitDatabase (..), UnitErr (..), emptyUnitState, @@ -29,7 +28,6 @@ module GHC.Unit.State ( lookupPackageName, resolvePackageImport, - improveUnit, searchPackageId, listVisibleModuleNames, lookupModuleInAllUnits, @@ -89,7 +87,6 @@ import GHC.Unit.Home import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique.Map import GHC.Types.Unique @@ -267,8 +264,6 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False -type PreloadUnitClosure = UniqSet UnitId - -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. type VisibilityMap = UniqMap Unit UnitVisibility @@ -431,13 +426,6 @@ data UnitState = UnitState { -- may have the 'exposed' flag be 'False'.) unitInfoMap :: UnitInfoMap, - -- | The set of transitively reachable units according - -- to the explicitly provided command line arguments. - -- A fully instantiated VirtUnit may only be replaced by a RealUnit from - -- this set. - -- See Note [VirtUnit to RealUnit improvement] - preloadClosure :: PreloadUnitClosure, - -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same -- package name (e.g. different instantiations), then we return one of them... -- This is used when users refer to packages in Backpack includes. @@ -490,7 +478,6 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, - preloadClosure = emptyUniqSet, packageNameMap = emptyUFM, wireMap = emptyUniqMap, unwireMap = emptyUniqMap, @@ -516,7 +503,7 @@ type UnitInfoMap = UniqMap UnitId UnitInfo -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo -lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs) +lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) -- | A more specialized interface, which doesn't require a 'UnitState' (so it -- can be used while we're initializing 'DynFlags') @@ -524,16 +511,15 @@ lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (prelo -- Parameters: -- * a boolean specifying whether or not to look for on-the-fly renamed interfaces -- * a 'UnitInfoMap' --- * a 'PreloadUnitClosure' -lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of HoleUnit -> error "Hole unit" RealUnit i -> lookupUniqMap pkg_map (unDefinite i) VirtUnit i | allowOnTheFlyInst -> -- lookup UnitInfo of the indefinite unit to be instantiated and -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map closure (instUnitInsts i)) + fmap (renameUnitInfo pkg_map (instUnitInsts i)) (lookupUniqMap pkg_map (instUnitInstanceOf i)) | otherwise @@ -907,7 +893,6 @@ applyTrustFlag prec_map unusable pkgs flag = applyPackageFlag :: UnitPrecedenceMap -> UnitInfoMap - -> PreloadUnitClosure -> UnusableUnits -> Bool -- if False, if you expose a package, it implicitly hides -- any previously exposed packages with the same name @@ -916,10 +901,10 @@ applyPackageFlag -> PackageFlag -- flag to apply -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = +applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> - case findPackages prec_map pkg_map closure arg pkgs unusable of + case findPackages prec_map pkg_map arg pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) Right (p:_) -> Succeeded vm' where @@ -983,7 +968,7 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = _ -> panic "applyPackageFlag" HidePackage str -> - case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of + case findPackages prec_map pkg_map (PackageArg str) pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) @@ -992,12 +977,11 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = -- if the 'UnitArg' has a renaming associated with it. findPackages :: UnitPrecedenceMap -> UnitInfoMap - -> PreloadUnitClosure -> PackageArg -> [UnitInfo] -> UnusableUnits -> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo] -findPackages prec_map pkg_map closure arg pkgs unusable +findPackages prec_map pkg_map arg pkgs unusable = let ps = mapMaybe (finder arg) pkgs in if null ps then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) @@ -1015,7 +999,7 @@ findPackages prec_map pkg_map closure arg pkgs unusable -> Just p VirtUnit inst | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p) + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) _ -> Nothing selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] @@ -1030,10 +1014,10 @@ selectPackages prec_map arg pkgs unusable else Right (sortByPreference prec_map ps, rest) -- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map closure insts conf = +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map closure hsubst + smod = renameHoleModule' pkg_map hsubst new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) in conf { unitInstantiations = new_insts, @@ -1631,7 +1615,7 @@ mkUnitState logger cfg = do -- user tries to enable an unusable package, we should let them know. -- vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + $ foldM (applyPackageFlag prec_map prelim_pkg_db unusable (unitConfigHideAll cfg) pkgs1) vis_map1 other_flags @@ -1660,7 +1644,7 @@ mkUnitState logger cfg = do | otherwise = vis_map2 plugin_vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + $ foldM (applyPackageFlag prec_map prelim_pkg_db unusable hide_plugin_pkgs pkgs1) plugin_vis_map1 (reverse (unitConfigFlagsPlugins cfg)) @@ -1712,7 +1696,7 @@ mkUnitState logger cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1722,9 +1706,8 @@ mkUnitState logger cfg = do , explicitUnits = explicit_pkgs , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db - , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1764,10 +1747,9 @@ mkModuleNameProvidersMap :: Logger -> UnitConfig -> UnitInfoMap - -> PreloadUnitClosure -> VisibilityMap -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = +mkModuleNameProvidersMap logger cfg pkg_map vis_map = -- What should we fold on? Both situations are awkward: -- -- * Folding on the visibility map means that we won't create @@ -1839,7 +1821,7 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid + unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid `orElse` pprPanic "unit_lookup" (ppr uid) exposed_mods = unitExposedModules pkg @@ -2190,44 +2172,16 @@ fsPackageName info = fs where PackageName fs = unitPackageName info - --- | Given a fully instantiated 'InstantiatedUnit', improve it into a --- 'RealUnit' if we can find it in the package database. -improveUnit :: UnitState -> Unit -> Unit -improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u - --- | Given a fully instantiated 'InstantiatedUnit', improve it into a --- 'RealUnit' if we can find it in the package database. -improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit -improveUnit' _ _ uid@(RealUnit _) = uid -- short circuit -improveUnit' pkg_map closure uid = - -- Do NOT lookup indefinite ones, they won't be useful! - case lookupUnit' False pkg_map closure uid of - Nothing -> uid - Just pkg -> - -- Do NOT improve if the indefinite unit id is not - -- part of the closure unique set. See - -- Note [VirtUnit to RealUnit improvement] - if unitId pkg `elementOfUniqSet` closure - then mkUnit pkg - else uid - --- | Check the database to see if we already have an installed unit that --- corresponds to the given 'InstantiatedUnit'. --- --- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or --- references a matching installed unit. --- --- See Note [VirtUnit to RealUnit improvement] -instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit -instUnitToUnit state iuid = +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = -- NB: suppose that we want to compare the instantiated -- unit p[H=impl:H] against p+abcd (where p+abcd -- happens to be the existing, installed version of -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] -- VirtUnit, they won't compare equal; only -- after improvement will the equality hold. - improveUnit state $ VirtUnit iuid + VirtUnit iuid -- | Substitution on module variables, mapping module names to module @@ -2239,30 +2193,30 @@ type ShHoleSubst = ModuleNameEnv Module -- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; -- similarly, @\<A>@ maps to @q():A@. renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module -renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state) +renameHoleModule state = renameHoleModule' (unitInfoMap state) -- | Substitutes holes in a 'Unit', suitable for renaming when -- an include occurs; see Note [Representation of module/name variables]. -- -- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@. renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit -renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state) +renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap' +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' -- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map closure env m +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map closure env (moduleUnit m) + let uid = renameHoleUnit' pkg_map env (moduleUnit m) in mkModule uid (moduleName m) | Just m' <- lookupUFM env (moduleName m) = m' -- NB m = <Blah>, that's what's in scope. | otherwise = m --- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap' +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' -- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map closure env uid = +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = case uid of (VirtUnit InstantiatedUnit{ instUnitInstanceOf = cid @@ -2270,20 +2224,15 @@ renameHoleUnit' pkg_map closure env uid = , instUnitHoles = fh }) -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'ClosureUnitInfoMap' to see if there is - -- a compiled version of this 'InstantiatedUnit' we can improve to. - -- See Note [VirtUnit to RealUnit improvement] - else improveUnit' pkg_map closure $ - mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts) + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) _ -> uid -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. -instModuleToModule :: UnitState -> InstantiatedModule -> Module -instModuleToModule pkgstate (Module iuid mod_name) = - mkModule (instUnitToUnit pkgstate iuid) mod_name +instModuleToModule :: InstantiatedModule -> Module +instModuleToModule (Module iuid mod_name) = + mkModule (instUnitToUnit iuid) mod_name -- | Print unit-ids with UnitInfo found in the given UnitState pprWithUnitState :: UnitState -> SDoc -> SDoc ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -250,9 +250,7 @@ data GenUnit uid -- -- This unit may be indefinite or not (i.e. with remaining holes or not). If it -- is definite, we don't know if it has already been compiled and installed in a --- database. Nevertheless, we have a mechanism called "improvement" to try to --- match a fully instantiated unit with existing compiled and installed units: --- see Note [VirtUnit to RealUnit improvement]. +-- database. -- -- An indefinite unit identifier pretty-prints to something like -- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'UnitId', and the View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43abe5dcaa22599a6f403c6381737df… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43abe5dcaa22599a6f403c6381737df… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/drop-cmm-gc-callconv
by Cheng Shao (＠TerrorJack) 12 Jun '26

12 Jun '26

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

1 0