- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-reinstallable-base2] 2 commits: text submodule
by Rodrigo Mesquita (＠alt-romes) 19 May '26

19 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 978ae62b by Rodrigo Mesquita at 2026-05-19T14:22:22+01:00 text submodule - - - - - ea593a29 by Rodrigo Mesquita at 2026-05-19T15:11:40+01:00 Fix assertion: missing exports from GHC Essentials Missing: Plugin/FrontendPlugin - - - - - 4 changed files: - compiler/GHC/Builtin/KnownKeys.hs - libraries/base/src/GHC/Essentials.hs - libraries/base/src/GHC/Exts.hs - libraries/text Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -257,8 +257,10 @@ knownKeyTable , (mkVarOcc "unpackCStringUtf8#", unpackCStringUtf8IdKey) -- JS primitives +#if defined(javascript_HOST_ARCH) , (mkVarOcc "unsafeUnpackJSStringUtf8##", unsafeUnpackJSStringUtf8ShShKey) , (mkTcOcc "JSVal", jsvalTyConKey) +#endif -- Type rep , (mkTcOcc "TyCon", trTyConTyConKey) @@ -425,7 +427,7 @@ monadFailClassKey :: KnownKey monadFailClassKey = mkPreludeClassUnique 29 monadPlusClassKey :: KnownKey -monadPlusClassKey = mkPreludeClassUnique 30 +monadPlusClassKey = mkPreludeClassUnique 30 isStringClassKey :: KnownKey isStringClassKey = mkPreludeClassUnique 33 ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -21,6 +21,7 @@ module GHC.Essentials , Functor, fmap, (<$) , Monad, (>>), (>>=), return, fail, guard, mfix, join , Alternative + , MonadFail, MonadPlus -- Misc , (.), (&&), not, foldrList, build, map @@ -145,7 +146,7 @@ module GHC.Essentials -- Static pointers , IsStatic( fromStaticPtr ), makeStatic - , StaticPtr, StaticPtrInfo( StaticPtrInfo ) + , StaticPtr( StaticPtr ), StaticPtrInfo( StaticPtrInfo ) -- Stable pointers , StablePtr, newStablePtr @@ -349,5 +350,5 @@ import GHC.Internal.Exception.Context import GHC.Internal.Ptr import GHC.Internal.Foreign.C.ConstPtr #if defined(javascript_HOST_ARCH) -import GHC.Internal.JS.Prim (unsafeUnpackJSStringUtf8##) +import GHC.Internal.JS.Prim (unsafeUnpackJSStringUtf8##, JSVal) #endif ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -73,12 +73,12 @@ module GHC.Exts -- ** Overloaded string literals IsString(..), -- ** CString - unpackCString#, - unpackAppendCString#, - unpackFoldrCString#, - unpackCStringUtf8#, - unpackNBytes#, - cstringLength#, + CS.unpackCString#, + CS.unpackAppendCString#, + CS.unpackFoldrCString#, + CS.unpackCStringUtf8#, + CS.unpackNBytes#, + CS.cstringLength#, -- * Debugging -- ** Breakpoints breakpoint, @@ -366,7 +366,20 @@ import GHC.Prim hiding import GHC.Prim.Ext +import qualified GHC.Types as CS ( + unpackCString#, + unpackAppendCString#, + unpackFoldrCString#, + unpackCStringUtf8#, + unpackNBytes#, + cstringLength# ) import GHC.Types hiding ( + unpackCString#, + unpackAppendCString#, + unpackFoldrCString#, + unpackCStringUtf8#, + unpackNBytes#, + cstringLength#, IO, -- Exported from "GHC.IO" Type, -- Exported from "Data.Kind" -- GHC's internal representation of 'TyCon's, for 'Typeable' ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit f77f28ce19bdcb7e5de1f9a23fc3f13ffc4bb9b1 +Subproject commit bfb985cdba77e5852e0eaf3ff77c1b4e8e9884d0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/395134b66b8aa71bcd602777bce603… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/395134b66b8aa71bcd602777bce603… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Disable `GHC.Internal.TH.Monad` import for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: e8011ea1 by Wolfgang Jeltsch at 2026-05-19T16:56:46+03:00 Disable `GHC.Internal.TH.Monad` import for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/Data/Array/Byte.hs Changes: ===================================== libraries/base/src/Data/Array/Byte.hs ===================================== @@ -8,6 +8,7 @@ -- -- Derived from @primitive@ package. +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} @@ -32,7 +33,9 @@ import GHC.Internal.Show (intToDigit) import GHC.Internal.ST (ST(..), runST) import GHC.Internal.Word (Word8(..)) import GHC.Internal.TH.Syntax -import GHC.Internal.TH.Monad +#if __GLASGOW_HASKELL__ >= 1000 +import GHC.Internal.TH.Monad (unsafeCodeCoerce) +#endif import GHC.Internal.TH.Lift import GHC.Internal.ForeignPtr import Prelude View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8011ea19b3f97effd178d209e60231… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8011ea19b3f97effd178d209e60231… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Add alternative `unsafeCodeCoerce` import for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 1b4fa9cf by Wolfgang Jeltsch at 2026-05-19T16:49:59+03:00 Add alternative `unsafeCodeCoerce` import for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/Data/Fixed.hs Changes: ===================================== libraries/base/src/Data/Fixed.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-} @@ -91,7 +92,11 @@ import GHC.Internal.TypeLits (KnownNat, natVal) import GHC.Internal.Read import GHC.Internal.Text.ParserCombinators.ReadPrec import GHC.Internal.Text.Read.Lex -import qualified GHC.Internal.TH.Monad as TH +#if __GLASGOW_HASKELL__ < 1000 +import GHC.Internal.TH.Syntax (unsafeCodeCoerce) +#else +import GHC.Internal.TH.Monad (unsafeCodeCoerce) +#endif import qualified GHC.Internal.TH.Lift as TH import Data.Typeable import Prelude @@ -147,7 +152,7 @@ instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where -- @since template-haskell-2.19.0.0 -- @since base-4.21.0.0 instance TH.Lift (Fixed a) where - liftTyped x = TH.unsafeCodeCoerce (TH.lift x) + liftTyped x = unsafeCodeCoerce (TH.lift x) lift (MkFixed x) = [| MkFixed x |] -- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution' typeclass. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b4fa9cf3ce942a2e7803a80a6f6842… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b4fa9cf3ce942a2e7803a80a6f6842… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] 2 commits: Disable GHC 9.14 `printToHandleFinalizerExceptionHandler`
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 3a6cf110 by Wolfgang Jeltsch at 2026-05-19T16:41:07+03:00 Disable GHC 9.14 `printToHandleFinalizerExceptionHandler` - - - - - ad3de112 by Wolfgang Jeltsch at 2026-05-19T16:42:31+03:00 Disable some imports into `Prelude` for GHC 9.14 - - - - - 4 changed files: - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/Mem/Weak.hs Changes: ===================================== libraries/base/src/GHC/Weak.hs ===================================== @@ -25,9 +25,8 @@ module GHC.Weak -- this handler will be ignored. setFinalizerExceptionHandler, getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler + GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler ) where import GHC.Internal.Weak -import GHC.Internal.Weak.Finalize import GHC.Weak.Finalize ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -7,7 +7,7 @@ module GHC.Weak.Finalize -- this handler will be ignored. setFinalizerExceptionHandler , getFinalizerExceptionHandler - , printToHandleFinalizerExceptionHandler + , GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler -- * Internal , GHC.Weak.Finalize.runFinalizerBatch ) where ===================================== libraries/base/src/Prelude.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ExplicitNamespaces #-} @@ -176,14 +177,16 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Traversable ( Traversable(..) ) import GHC.Internal.Data.Tuple -import GHC.Internal.Base hiding ( foldr, mapM, sequence ) +#if __GLASGOW_HASKELL__ >= 1000 import GHC.Internal.Classes import GHC.Internal.Err +import GHC.Internal.Prim (seq) +import GHC.Internal.Types +#endif +import GHC.Internal.Base hiding ( foldr, mapM, sequence ) import Text.Read import GHC.Internal.Enum import GHC.Internal.Num -import GHC.Internal.Prim (seq) import GHC.Internal.Real import GHC.Internal.Float import GHC.Internal.Show -import GHC.Internal.Types ===================================== libraries/base/src/System/Mem/Weak.hs ===================================== @@ -78,7 +78,7 @@ module System.Mem.Weak ( -- this handler will be ignored. setFinalizerExceptionHandler, getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler, + GHC.Weak.printToHandleFinalizerExceptionHandler, -- * A precise semantics View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8bdbb20c3e6c8187ff11c933ab4e83… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8bdbb20c3e6c8187ff11c933ab4e83… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/T27202] 2 commits: fixup! Fix regression T27202: `:load` and `:add` work in GHCi
by Hannes Siebenhandl (＠fendor) 19 May '26

19 May '26

Hannes Siebenhandl pushed to branch wip/fendor/T27202 at Glasgow Haskell Compiler / GHC Commits: a1aa8f58 by fendor at 2026-05-19T15:38:30+02:00 fixup! Fix regression T27202: `:load` and `:add` work in GHCi - - - - - c09bc29c by fendor at 2026-05-19T15:38:30+02:00 Use home unit package db stacks in GHCi prompt and session unit In order to import modules from home unit dependencies (e.g., `Data.Map`), the ghci prompt unit needs to populate its `UnitState`. This is tricky to handle correctly, which `PackageDBFlag`s should we use to populate the `UnitState`? We decide, the most intuitive solution for users is to depend on all `PackageDBFlag`s, so that any dependency can be imported in GHCi. This assumes consistency in the `PackageDBFlag`s, so no two home units specify `PackageDBFlag`s that are inconsistent with each other. We could simply concat all the `PackageDBFlag`s of the existing home units, but later `PackageDBFlag`s shadow earlier ones, leading to the last processed home units' `PackageDBFlag`s to shadow the earlier ones. This is hard to fix, we need to give users the capability to provide ghc options for the ghci prompt home unit. However, as this is considerably more work, we decided on an approximation that should work out most of the time. Package Db stacks in cabal and stack follow a certain structure: -no-user-package-db > -package-db $cabal-store > -package-db $local-db The first two arguments are always the same, namely the `-no-user-package-db` and `-package-db`. We compute the longest common prefix over all home units, and use that as the start of the package db stack. Then, over the rest of the `PackageDBFlag`s, we simply take the union and append them to our initial stack. We assume, that the rest of package dbs only defines very few, "local" units that are usually not shadowing each other. This allows us to get a relatively consistent package database stack for the ghci prompt home unit. Similar reasoning applies to the session unit in order to add modules to the session and have dependencies available in the module. We do something similar for `-package` flags, to make sure only the correct units are actually visible in the ghci session. This time, we simply take the union of all `PackageFlag`s, allowing us to import modules from the home unit dependencies. In the future, it would be beneficial to allow the user to provide the exact ghc options to control the visibilities. For now, this will have to do. - - - - - 24 changed files: - changelog.d/T27202 - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - + testsuite/tests/ghci/prog-mhu006/Makefile - + testsuite/tests/ghci/prog-mhu006/a/A.hs - + testsuite/tests/ghci/prog-mhu006/all.T - + testsuite/tests/ghci/prog-mhu006/b/B.hs - + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script - + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout - + testsuite/tests/ghci/prog-mhu006/unitA - + testsuite/tests/ghci/prog-mhu006/unitB - testsuite/tests/ghci/prog003/prog003.T - + testsuite/tests/ghci/prog025/Makefile - + testsuite/tests/ghci/prog025/a/A.hs - + testsuite/tests/ghci/prog025/all.T - + testsuite/tests/ghci/prog025/prog025a.script - + testsuite/tests/ghci/prog025/prog025a.stdout - + testsuite/tests/ghci/prog025/prog025b.script - + testsuite/tests/ghci/prog025/prog025b.stdout - + testsuite/tests/ghci/prog025/testpkg/Test.hs - + testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg - + testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg - + testsuite/tests/ghci/prog025/unitA Changes: ===================================== changelog.d/T27202 ===================================== @@ -1,9 +1,13 @@ section: ghci -synopsis: Fix regression to allow loading modules into the GHCi after startup. +synopsis: Fix regression to honour module targets in nested directories into GHCi after startup. issues: #27202 mrs: !15980 description: { Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup. GHCi wasn't honouring the `-i<directory>` argument if given via `ghci -i<directory>`. + + Further, we fix a bug while setting up package database stacks for GHCi that was uncovered during this fix. + By underspecifying the version of dependencies, import modules from dependencies were ambiguous, even though + they shouldn't have been! } ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Driver.DynFlags ( packageFlagsChanged, IgnorePackageFlag(..), TrustFlag(..), PackageDBFlag(..), PkgDbRef(..), + isPackageDbRef, Option(..), showOpt, DynLibLoader(..), positionIndependent, @@ -881,7 +882,7 @@ isNoLink _ = False data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance Outputable PackageArg where ppr (PackageArg pn) = text "package" <+> text pn @@ -902,7 +903,7 @@ data ModRenaming = ModRenaming { modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope -- under name @n@. - } deriving (Eq) + } deriving (Eq, Ord) instance Outputable ModRenaming where ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) @@ -920,14 +921,21 @@ data TrustFlag data PackageFlag = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ | HidePackage String -- ^ @-hide-package@ - deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + deriving (Eq, Ord) -- NB: equality instance is used by packageFlagsChanged data PackageDBFlag = PackageDB PkgDbRef | NoUserPackageDB | NoGlobalPackageDB | ClearPackageDBs - deriving (Eq) + deriving (Eq, Ord) + +isPackageDbRef :: PackageDBFlag -> Maybe PkgDbRef +isPackageDbRef = \ case + PackageDB ref -> Just ref + NoUserPackageDB -> Nothing + NoGlobalPackageDB -> Nothing + ClearPackageDBs -> Nothing packageFlagsChanged :: DynFlags -> DynFlags -> Bool packageFlagsChanged idflags1 idflags0 = @@ -1009,7 +1017,7 @@ data PkgDbRef = GlobalPkgDb | UserPkgDb | PkgDbPath OsPath - deriving Eq + deriving (Eq, Ord) ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -68,7 +68,9 @@ module GHC.Unit.State ( pprRawUnitIds, -- * Utils - unwireUnit) + unwireUnit, + selectHptFlag, + ) where import GHC.Prelude ===================================== ghc/GHCi/UI.hs ===================================== @@ -9,6 +9,7 @@ {-# OPTIONS -fno-warn-name-shadowing #-} -- This module does a lot of it +{-# OPTIONS -Wno-x-partial #-} ----------------------------------------------------------------------------- -- @@ -53,6 +54,7 @@ import GHC.Driver.Errors (printOrThrowDiagnostics) import GHC.Driver.Errors.Types import GHC.Driver.Phases import GHC.Driver.Session as DynFlags +import GHC.Driver.DynFlags as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) import GHC.Driver.Monad ( modifySession, modifySessionM ) @@ -131,6 +133,7 @@ import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) +import qualified Data.List as List import qualified Data.List.NonEmpty as NE import qualified Data.Set as S import Data.Maybe @@ -745,6 +748,48 @@ installInteractiveHomeUnits dflags = do sessionUnitExposedFlag = homeUnitPkgFlag interactiveSessionUnitId + -- Currently, we are in a somewhat awkward situation. + -- Users clearly want to control precisely which packages are available at the GHCi prompt, + -- but there is currently no way for the user to declaratively change the set of packages + -- available at the prompt. Thus, a bit of guessing is necessary to provide the reasonable + -- GHCi UX experience, but in the future, we might want to give the user more precise control. + -- + -- The prompt and session home unit may not have any package db specified, but we still want to + -- to import modules from our home unit dependencies. + -- To make this possible, the prompt and session home unit need to have a package db, but which one? + -- We decide, if a package db is given at the top level, e.g. @ghci -package-db ...@, + -- then we honour what the user requests and only use this @-package-db@. + -- However, in the case of multiple home units, initialised via @ghci -unit ... -unit ...@, there + -- are not @-package-db@ arguments in the base 'DynFlags'... + -- To fix this, we look at the home units and merge their package dbs stacks. + -- We assume, that many package db stacks look almost identical, and only differ in view elements. + -- Thus, we try to extract a common package db stack (i.e., longest common prefix), and then concat + -- the rest of the package db stacks. At last, we add the two result package db stacks. + -- This should work reliably with cabal and stack, but it is hacky. + -- A proper solution would be to teach cabal and other tooling to specify the correct package db + -- stacks for the prompt and session home unit. + ghciPackageDbStacks = + if all (isNothing . DynFlags.isPackageDbRef) (packageDBFlags dflags0) + then + HUG.unitEnv_assocs (hsc_HUG hsc_env) + & concatPackageDbStacksUsingLongestCommonPrefix . map (packageDBFlags . HUG.homeUnitEnv_dflags . snd) + else + packageDBFlags dflags0 + + -- Make sure the prompt and session home unit use the correct dependencies. + ghciPackageFlags = + if null (packageFlags dflags0) + then + HUG.unitEnv_assocs (hsc_HUG hsc_env) + & concatMap (packageFlags . HUG.homeUnitEnv_dflags . snd) + -- We don't want to add `-package-id` flags for home units. + -- This is mostly for a clear separation of concerns, + -- to indicate we only care about unit dependencies from package dbs. + & filter (not . selectHptFlag (HUG.allUnits $ hsc_HUG hsc_env)) + & ordNub + else + packageFlags dflags0 + -- Explicitly depends on all home units and 'sessionUnitExposedFlag'. -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags' -- of the 'InteractiveContext'. @@ -759,8 +804,9 @@ installInteractiveHomeUnits dflags = do , [ homeUnitPkgFlag uid | uid <- S.toList $ HUG.allUnits $ hsc_HUG hsc_env ] - , packageFlags dflags0 + , ghciPackageFlags ] + , packageDBFlags = ghciPackageDbStacks , importPaths = [] } @@ -773,25 +819,19 @@ installInteractiveHomeUnits dflags = do [ [ homeUnitPkgFlag uid | uid <- S.toList $ HUG.allUnits $ hsc_HUG hsc_env ] - , packageFlags dflags + , ghciPackageFlags ] + , packageDBFlags = ghciPackageDbStacks } let - cached_unit_dbs = - concat - . catMaybes - . fmap homeUnitEnv_unit_dbs - $ Foldable.toList - $ hsc_HUG hsc_env - all_unit_ids = S.insert interactiveGhciUnitId $ S.insert interactiveSessionUnitId $ hsc_all_home_unit_ids hsc_env - ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs - ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs + ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids + ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids let -- Setup up the HUG, install the interactive home units withInteractiveUnits = @@ -813,13 +853,26 @@ installInteractiveHomeUnits dflags = do pure () where - setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv - setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do + setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv + setupHomeUnitFor logger dflags all_home_units = do (dbs,unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units + liftIO $ initUnits logger dflags Nothing all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] + concatPackageDbStacksUsingLongestCommonPrefix stacks = + let + -- O (m * n) + -- m ... Number of PackageDBFlag stacks + -- n ... Size of the stacks + longestCommonPrefix = + map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose + prefix = + longestCommonPrefix stacks + in + prefix ++ ordNub (concatMap (List.drop (length prefix)) stacks) + reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do printError err ===================================== testsuite/tests/ghci/prog-mhu006/Makefile ===================================== @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: prog-mhu006a +prog-mhu006a: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db \ + -unit @unitA -unit @unitB < prog-mhu006a.script ===================================== testsuite/tests/ghci/prog-mhu006/a/A.hs ===================================== @@ -0,0 +1 @@ +module A where ===================================== testsuite/tests/ghci/prog-mhu006/all.T ===================================== @@ -0,0 +1,8 @@ + +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB']) + +test('prog-mhu006a', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog-mhu006a']) ===================================== testsuite/tests/ghci/prog-mhu006/b/B.hs ===================================== @@ -0,0 +1 @@ +module B where ===================================== testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script ===================================== @@ -0,0 +1,4 @@ +"Can import modules from dependencies" +:m + Data.ByteString +:m + Data.Text +"Imported Data.ByteString and Data.Text" ===================================== testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout ===================================== @@ -0,0 +1,2 @@ +"Can import modules from dependencies" +"Imported Data.ByteString and Data.Text" ===================================== testsuite/tests/ghci/prog-mhu006/unitA ===================================== @@ -0,0 +1,9 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-global-package-db +-package base +-package-id b-0.0.0 +-package containers ===================================== testsuite/tests/ghci/prog-mhu006/unitB ===================================== @@ -0,0 +1,8 @@ +-i +-ib/ +B +-this-unit-id b-0.0.0 +-this-package-name b +-global-package-db +-package base +-package bytestring ===================================== testsuite/tests/ghci/prog003/prog003.T ===================================== @@ -5,6 +5,5 @@ test('prog003', [extra_files(['A.hs', 'B.hs', 'C.hs', 'D1.hs', 'D2.hs']), when(opsys('mingw32'), skip), - unless(config.ghc_dynamic, expect_broken(20704)), cmd_prefix('ghciWayFlags=' + config.ghci_way_flags)], ghci_script, ['prog003.script']) ===================================== testsuite/tests/ghci/prog025/Makefile ===================================== @@ -0,0 +1,54 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +PKGCONF01=local01.package.conf +LOCAL_GHC_PKG01 = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF01) + +# When the user package databases are cleared, the GHCi prompt still needs to be able to find +# modules from home unit dependencies. +# Moreover, it needs to find the correct dependency unit, not just any. +.PHONY: prog025a +prog025a: + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.1.0.0 -this-unit-id testpkg-0.1.0.0-XXX \ + -i. Test + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.2.0.0 -this-unit-id testpkg-0.2.0.0-XXX \ + -i. Test + + $(LOCAL_GHC_PKG01) init $(PKGCONF01) 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.1.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.2.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) hide testpkg-0.1.0.0 + $(LOCAL_GHC_PKG01) hide testpkg-0.2.0.0 + $(LOCAL_GHC_PKG01) list + + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code -unit @unitA < prog025a.script + +# Same as prog025a, but the home unit arguments are not provided using a response file +.PHONY: prog025b +prog025b: + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.1.0.0 -this-unit-id testpkg-0.1.0.0-XXX \ + -i. Test + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.2.0.0 -this-unit-id testpkg-0.2.0.0-XXX \ + -i. Test + + $(LOCAL_GHC_PKG01) init $(PKGCONF01) 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.1.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.2.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) hide testpkg-0.1.0.0 + $(LOCAL_GHC_PKG01) hide testpkg-0.2.0.0 + $(LOCAL_GHC_PKG01) list + + # Uses response file for argument, doesn't use it as a -unit argument + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code \ + @unitA < prog025b.script ===================================== testsuite/tests/ghci/prog025/a/A.hs ===================================== @@ -0,0 +1,3 @@ +module A where + +import Test ===================================== testsuite/tests/ghci/prog025/all.T ===================================== @@ -0,0 +1,14 @@ + +proj_files = extra_files(['a/', 'unitA', 'testpkg/']) + +test('prog025a', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog025a']) + +test('prog025b', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog025b']) ===================================== testsuite/tests/ghci/prog025/prog025a.script ===================================== @@ -0,0 +1,2 @@ +:m + Test +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025a.stdout ===================================== @@ -0,0 +1,7 @@ +Reading package info from "testpkg/testpkg-0.1.0.0.pkg" ... done. +Reading package info from "testpkg/testpkg-0.2.0.0.pkg" ... done. +local01.package.conf + (testpkg-0.1.0.0) + (testpkg-0.2.0.0) + +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025b.script ===================================== @@ -0,0 +1,2 @@ +:m + Test +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025b.stdout ===================================== @@ -0,0 +1,7 @@ +Reading package info from "testpkg/testpkg-0.1.0.0.pkg" ... done. +Reading package info from "testpkg/testpkg-0.2.0.0.pkg" ... done. +local01.package.conf + (testpkg-0.1.0.0) + (testpkg-0.2.0.0) + +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/testpkg/Test.hs ===================================== @@ -0,0 +1 @@ +module Test where ===================================== testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg +version: 0.1.0.0 +id: testpkg-0.1.0.0-XXX +key: testpkg-0.1.0.0-XXX +exposed: True +exposed-modules: Test +hidden-modules: +import-dirs: ${pkgroot}/dist-testpkg-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg +version: 0.2.0.0 +id: testpkg-0.2.0.0-XXX +key: testpkg-0.2.0.0-XXX +exposed: True +exposed-modules: Test +hidden-modules: +import-dirs: ${pkgroot}/testpkg/dist-testpkg-0.2.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog025/unitA ===================================== @@ -0,0 +1,11 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local01.package.conf +-package base +-package-id testpkg-0.2.0.0-XXX View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9894df286c1aa592208c790de893d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9894df286c1aa592208c790de893d8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Disable some imports into `Prelude` for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 8bdbb20c by Wolfgang Jeltsch at 2026-05-19T16:18:07+03:00 Disable some imports into `Prelude` for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/Prelude.hs Changes: ===================================== libraries/base/src/Prelude.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ExplicitNamespaces #-} @@ -176,14 +177,16 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Traversable ( Traversable(..) ) import GHC.Internal.Data.Tuple -import GHC.Internal.Base hiding ( foldr, mapM, sequence ) +#if __GLASGOW_HASKELL__ >= 1000 import GHC.Internal.Classes import GHC.Internal.Err +import GHC.Internal.Prim (seq) +import GHC.Internal.Types +#endif +import GHC.Internal.Base hiding ( foldr, mapM, sequence ) import Text.Read import GHC.Internal.Enum import GHC.Internal.Num -import GHC.Internal.Prim (seq) import GHC.Internal.Real import GHC.Internal.Float import GHC.Internal.Show -import GHC.Internal.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bdbb20c3e6c8187ff11c933ab4e830… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bdbb20c3e6c8187ff11c933ab4e830… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] prefer KnownKeys to KnownOcc, bit of polish
by Rodrigo Mesquita (＠alt-romes) 19 May '26

19 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 395134b6 by Rodrigo Mesquita at 2026-05-19T14:16:19+01:00 prefer KnownKeys to KnownOcc, bit of polish - - - - - 7 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -246,7 +246,7 @@ How known-occ entities work * Known-occ lookup (normal case: KES_FromModule) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In normal client code, suppose the desugarer calls - dsLookupKnownKeyTyCon rationalTyConKey + dsLookupKnownKeyTyCon ioTyConKey or dsLookupKnownOccTyCon rationalTyConOcc @@ -304,8 +304,8 @@ Known-key entities are * All the known-key names are gathered in one table: knownKeyTable :: [(KnownOcc, KnownKey)] knownKeyTable - = [ (mkTcOcc "Rational", rationalTyConKey) - , (mkTcOcc "Eq", eqClassKey) + = [ (mkTcOcc "IO", ioTyConKey) + , (mkTcOcc "Eq", eqClassKey) ... etc ... ] * Because of (KnownOccNameInvariant) we can turn that table into two mappings: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -379,8 +379,6 @@ pureAClassOpOcc = mkVarOcc "pure" returnMClassOpOcc = mkVarOcc "return" thenMClassOpOcc = mkVarOcc ">>" bindMClassOpOcc = mkVarOcc ">>=" - -- ROMES:TODO: bindMClassOpOcc does not have a Known Names Table Entry. What - -- happens to all these occs needed for Quote? Should we make them just KnownOcc? thenAClassOpOcc = mkVarOcc "*>" mappendClassOpOcc = mkVarOcc "mappend" getFieldClassOpOcc = mkVarOcc "getField" @@ -483,7 +481,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, maybeTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, - orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, + orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, stringTyConKey, ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: KnownKey @@ -519,9 +517,7 @@ mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 orderingTyConKey = mkPreludeTyConUnique 32 mVarPrimTyConKey = mkPreludeTyConUnique 33 --- ioPortPrimTyConKey (34) was killed ratioTyConKey = mkPreludeTyConUnique 35 -rationalTyConKey = mkPreludeTyConUnique 36 realWorldTyConKey = mkPreludeTyConUnique 37 stablePtrPrimTyConKey = mkPreludeTyConUnique 38 stablePtrTyConKey = mkPreludeTyConUnique 39 ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -179,14 +179,8 @@ fromStaticPtrClassOpOcc, newStablePtrIdOcc :: KnownOcc fromStaticPtrClassOpOcc = mkVarOcc "fromStaticPtr" newStablePtrIdOcc = mkVarOcc "newStablePtr" -staticPtrTyConOcc, staticPtrInfoDataConOcc :: KnownOcc -staticPtrTyConOcc = mkTcOcc "StaticPtr" -staticPtrInfoDataConOcc = mkDataOcc "StaticPtrInfo" - -knownNatClassOcc, knownSymbolClassOcc, knownCharClassOcc :: KnownOcc -knownNatClassOcc = mkTcOcc "KnownNat" -knownSymbolClassOcc = mkTcOcc "KnownSymbol" -knownCharClassOcc = mkTcOcc "KnownChar" +staticPtrTyConOcc :: KnownOcc +staticPtrTyConOcc = mkTcOcc "StaticPtr" returnIOIdOcc, bindIOIdOcc, thenIOIdOcc, printIdOcc, ioTyConOcc, ioDataConOcc :: KnownOcc @@ -226,11 +220,10 @@ typeLitCharDataConOcc = mkDataOcc "TypeLitChar" trModuleTyConOcc, trModuleDataConOcc, trNameSDataConOcc - , trTyConTyConOcc, trTyConDataConOcc :: KnownOcc + , trTyConDataConOcc :: KnownOcc trModuleTyConOcc = mkTcOcc "Module" trModuleDataConOcc = mkDataOcc "Module" trNameSDataConOcc = mkDataOcc "TrNameS" -trTyConTyConOcc = mkTcOcc "TyCon" trTyConDataConOcc = mkDataOcc "TyCon" -- Typeable representation types ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -137,7 +137,7 @@ import GHC.Iface.Errors.Types import Language.Haskell.Syntax.BooleanFormula (BooleanFormula) import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..)) import Language.Haskell.Syntax.Extension (NoExtField (NoExtField)) -import GHC.Builtin.KnownOccs (ioTyConOcc) +import GHC.Builtin.KnownKeys (ioTyConKey) {- This module takes @@ -983,7 +983,7 @@ mk_top_id (IfGblTopBndr gbl_name) -- rather than the current module so we need this special case. -- See some similar logic in `GHC.Rename.Env`. | Just rOOT_MAIN == nameModule_maybe gbl_name - = lookupKnownOccThing ioTyConOcc KES_FromModule >>= \case + = lookupKnownKeyThing ioTyConKey KES_FromModule >>= \case Failed err -> failIfM (pprDiagnostic err) Succeeded ioTyThing -> do ATyCon ioTyCon <- pure ioTyThing ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -27,13 +27,12 @@ import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Prim import GHC.Builtin.KnownKeys -import GHC.Builtin.KnownOccs import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Builtin.PrimOps.Ids ( primOpId ) import GHC.Types.FieldLabel import GHC.Types.SafeHaskell -import GHC.Types.Name ( Name, KnownOcc ) +import GHC.Types.Name ( Name, KnownKey ) import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id @@ -961,9 +960,9 @@ matchTypeable clas [k,t] -- clas = Typeable -- see Note [No Typeable for polytypes or qualified types] -- Now cases that do work - | k `eqType` naturalTy = doTyLit knownNatClassOcc t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassOcc t - | k `eqType` charTy = doTyLit knownCharClassOcc t + | k `eqType` naturalTy = doTyLit knownNatClassKey t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassKey t + | k `eqType` charTy = doTyLit knownCharClassKey t | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks @@ -1039,8 +1038,8 @@ mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal -- we generate a sub-goal for the appropriate class. -- See Note [Typeable for Nat and Symbol] -doTyLit :: KnownOcc -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupKnownOccClass kc +doTyLit :: KnownKey -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupKnownKeyClass kc ; let kc_pred = mkClassPred kc_clas [ t ] mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) mk_ev _ = panic "doTyLit" ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Iface.Env( newGlobalBinder ) import GHC.Builtin.Modules( gHC_TYPES, gHC_PRIM ) import GHC.Builtin.KnownOccs +import GHC.Builtin.KnownKeys (trTyConTyConKey) import GHC.Builtin.WiredIn.Prim ( primTyCons ) import GHC.Builtin.WiredIn.Types ( runtimeRepTyCon @@ -428,7 +429,7 @@ data TyConTodo todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupKnownOccTyCon trTyConTyConOcc + trTyConTy <- mkTyConTy <$> tcLookupKnownKeyTyCon trTyConTyConKey let mk_rep_id :: TyConRepName -> Id mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy `setInlinePragma` neverInlinePragma ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1975,7 +1975,7 @@ generateMainBinding tcg_env main_name = do getIOType :: TcM (TcType, TcType) -- Return (IO alpha, alpha) for fresh alpha -getIOType = do { ioTyCon <- tcLookupKnownOccTyCon ioTyConOcc +getIOType = do { ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey ; res_ty <- newFlexiTyVarTy liftedTypeKind ; return (mkTyConApp ioTyCon [res_ty], res_ty) } @@ -2589,7 +2589,7 @@ getGhciStepIO :: TcM (LHsExpr GhcRn) getGhciStepIO = do ghciTy <- getGHCiMonad a_tv <- newName (mkTyVarOccFS (fsLit "a")) - ioTyCon <- tcLookupKnownOccTyCon ioTyConOcc + ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) ioM = nlHsAppTy (nlHsTyVar NotPromoted (tyConName ioTyCon)) (nlHsTyVar NotPromoted a_tv) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395134b66b8aa71bcd602777bce6031… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395134b66b8aa71bcd602777bce6031… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27113-retry] rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113)
by Zubin (＠wz1000) 19 May '26

19 May '26

Zubin pushed to branch wip/27113-retry at Glasgow Haskell Compiler / GHC Commits: daa65163 by Zubin Duggal at 2026-05-19T18:46:15+05:30 rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113) Closes a race in the threaded RTS where a SIGPIPE fired by throwTo to cancel an interruptible foreign call may land in the user-space prologue of the FFI wrapper, between suspendThread releasing the capability and the kernel syscall starting. GHC's empty SIGPIPE handler swallows the signal and the syscall then blocks forever. - - - - - 11 changed files: - rts/RaiseAsync.c - rts/Schedule.c - rts/Schedule.h - rts/Task.c - rts/Task.h - rts/Timer.c - testsuite/tests/concurrent/should_run/T27113.hs - testsuite/tests/concurrent/should_run/T27113_c.c - + testsuite/tests/concurrent/should_run/T27113b.hs - + testsuite/tests/concurrent/should_run/T27113c.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== rts/RaiseAsync.c ===================================== @@ -36,6 +36,11 @@ static void throwToSendMsg (Capability *cap USED_IF_THREADS, Capability *target_cap USED_IF_THREADS, MessageThrowTo *msg USED_IF_THREADS); +#if defined(THREADED_RTS) +static void clear_interrupt_pending_if_no_live_throw (Capability *cap, + StgTSO *target); +#endif + /* ----------------------------------------------------------------------------- throwToSingleThreaded @@ -338,7 +343,13 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + StgTSO *m_target = m->target; +#endif doneWithMsgThrowTo(cap, m); +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif raiseAsync(cap, target, msg->exception, false, NULL); return THROWTO_SUCCESS; @@ -433,11 +444,12 @@ check_target: #if defined(THREADED_RTS) { Task *task = NULL; - // walk suspended_ccalls to find the correct worker thread + InCall *target_incall = NULL; InCall *incall; for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) { if (incall->suspended_tso == target) { task = incall->task; + target_incall = incall; break; } } @@ -446,6 +458,7 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -520,8 +533,14 @@ blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) ASSERT(target->cap == cap); dirty_TSO(cap,target); // we will modify the blocked_exceptions queue +#if defined(THREADED_RTS) + ACQUIRE_LOCK(&cap->lock); +#endif msg->link = target->blocked_exceptions; - target->blocked_exceptions = msg; + RELEASE_STORE(&target->blocked_exceptions, msg); +#if defined(THREADED_RTS) + RELEASE_LOCK(&cap->lock); +#endif } /* ----------------------------------------------------------------------------- @@ -664,6 +683,46 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +static void +clear_interrupt_pending_if_no_live_throw (Capability *cap, StgTSO *target) +{ + if (target == NULL) return; + if (ACQUIRE_LOAD(&target->why_blocked) != BlockedOnCCall_Interruptible) + return; + + Capability *target_cap = ACQUIRE_LOAD(&target->cap); + ACQUIRE_LOCK(&target_cap->lock); + + // Find the InCall on target_cap. If target has already resumed (or + // wasn't really suspended on this cap), do nothing. + InCall *found = NULL; + for (InCall *ic = target_cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ic->suspended_tso == target) { found = ic; break; } + } + if (found == NULL) { + RELEASE_LOCK(&target_cap->lock); + return; + } + + bool live = false; + for (MessageThrowTo *t = ACQUIRE_LOAD(&target->blocked_exceptions); + t != END_BLOCKED_EXCEPTIONS_QUEUE; + t = (MessageThrowTo*)t->link) { + if (RELAXED_LOAD((StgWord*)&t->header.info) + != (StgWord)&stg_MSG_NULL_info) { + live = true; break; + } + } + if (!live) { + RELEASE_STORE(&found->interrupt_pending, 0); + } + + RELEASE_LOCK(&target_cap->lock); + (void)cap; +} +#endif + static void removeFromQueues(Capability *cap, StgTSO *tso) { @@ -699,8 +758,16 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + StgTSO *m_target = m->target; +#endif + // unlock and revoke it at the same time doneWithMsgThrowTo(cap, m); + +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif break; } ===================================== rts/Schedule.c ===================================== @@ -2536,6 +2536,25 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + if (interruptible + && !((tso->flags & TSO_BLOCKEX) && + ((tso->flags & TSO_INTERRUPTIBLE) == 0))) { + MessageThrowTo *head = ACQUIRE_LOAD(&tso->blocked_exceptions); + bool live = false; + for (MessageThrowTo *m = head; + m != END_BLOCKED_EXCEPTIONS_QUEUE; + m = (MessageThrowTo*)m->link) { + if (RELAXED_LOAD((StgWord*)&m->header.info) + != (StgWord)&stg_MSG_NULL_info) { live = true; break; } + } + if (live) { + RELEASE_STORE(&task->incall->interrupt_pending, 1); + } + } +#endif + releaseCapability_(cap,false); RELEASE_LOCK(&cap->lock); @@ -2574,8 +2593,10 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + ACQUIRE_LOCK(&cap->lock); + RELEASE_STORE(&incall->interrupt_pending, 0); recoverSuspendedTask(cap,task); + RELEASE_LOCK(&cap->lock); tso = incall->suspended_tso; incall->suspended_tso = NULL; @@ -2614,6 +2635,31 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +void +retryInterruptibleSignals(void) +{ + bool any_pending = false; + uint32_t n = getNumCapabilities(); + for (uint32_t i = 0; i < n; i++) { + Capability *cap = getCapability(i); + if (RELAXED_LOAD(&cap->n_suspended_ccalls) == 0) continue; + if (TRY_ACQUIRE_LOCK(&cap->lock) != 0) continue; + for (InCall *ic = cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ACQUIRE_LOAD(&ic->interrupt_pending) == 0) continue; + // ic->task is set by newInCall and never cleared. + if (ic->task != NULL) { + any_pending = true; + interruptOSThread(ic->task->id); + } + } + RELEASE_LOCK(&cap->lock); + } + // Keep the timer alive; handle_tick's idle path would otherwise stop it. + if (any_pending) setRecentActivity(ACTIVITY_YES); +} +#endif + /* --------------------------------------------------------------------------- * scheduleThread() * ===================================== rts/Schedule.h ===================================== @@ -43,6 +43,10 @@ void scheduleThreadOn(Capability *cap, StgWord cpu, StgTSO *tso); void wakeUpRts(void); #endif +#if defined(THREADED_RTS) +void retryInterruptibleSignals(void); +#endif + /* raiseExceptionHelper */ StgWord raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception); ===================================== rts/Task.c ===================================== @@ -267,6 +267,7 @@ newInCall (Task *task) incall->next = NULL; incall->prev = NULL; incall->prev_stack = task->incall; + incall->interrupt_pending = 0; task->incall = incall; } ===================================== rts/Task.h ===================================== @@ -106,6 +106,8 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,9 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + if (SEQ_CST_LOAD_ALWAYS(&timer_disabled) == 0) { + retryInterruptibleSignals(); + } #endif /* ===================================== testsuite/tests/concurrent/should_run/T27113.hs ===================================== @@ -10,7 +10,7 @@ import System.IO import System.Timeout foreign import ccall interruptible "cpu_then_pause" - c_cpu_then_pause :: CLong -> IO () + c_cpu_then_pause :: CLLong -> IO () killDelay :: Int killDelay = 200_000 @@ -18,7 +18,7 @@ killDelay = 200_000 joinTimeout :: Int joinTimeout = 3_000_000 -runCase :: String -> CLong -> IO () +runCase :: String -> CLLong -> IO () runCase name spinNs = do tid <- forkIO $ c_cpu_then_pause spinNs ===================================== testsuite/tests/concurrent/should_run/T27113_c.c ===================================== @@ -1,17 +1,18 @@ #include <errno.h> +#include <stdint.h> #include <time.h> #include <unistd.h> -static long now_ns(void) { +static int64_t now_ns(void) { struct timespec t; while (clock_gettime(CLOCK_MONOTONIC, &t) != 0) { if (errno != EINTR) return 0; } - return (long)t.tv_sec * 1000000000L + (long)t.tv_nsec; + return (int64_t)t.tv_sec * 1000000000LL + (int64_t)t.tv_nsec; } -int cpu_then_pause(long spin_ns) { - long deadline = now_ns() + spin_ns; +int cpu_then_pause(int64_t spin_ns) { + int64_t deadline = now_ns() + spin_ns; while (now_ns() < deadline) { } return pause(); ===================================== testsuite/tests/concurrent/should_run/T27113b.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Foreign.C.Types +import System.IO +import System.Timeout + +foreign import ccall interruptible "cpu_then_pause" + c_cpu_then_pause :: CLLong -> IO () + +myCall :: CLLong -> IO () +myCall spinNs = mask_ $ do + allowInterrupt + c_cpu_then_pause spinNs + allowInterrupt + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + started <- newEmptyMVar + done <- newEmptyMVar + tid <- mask_ $ forkIOWithUnmask $ \unmask -> + flip finally (putMVar done ()) $ do + putMVar started () + unmask (myCall 2_000_000_000) + `catch` (\(_ :: SomeException) -> return ()) + takeMVar started + threadDelay 200_000 + result <- timeout 5_000_000 (killThread tid >> takeMVar done) + case result of + Just () -> putStrLn "ok" + Nothing -> do + hPutStrLn stderr "FAIL: killThread hung" + error "hung" ===================================== testsuite/tests/concurrent/should_run/T27113c.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import Foreign.C.Types +import System.Exit +import System.IO + +foreign import ccall interruptible "pause" c_pause :: IO CInt + +postRevokeWindow :: Int +postRevokeWindow = 2_000_000 + +postRevokeThreshold :: Int +postRevokeThreshold = 5 + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + iters <- newIORef (0 :: Int) + + workerStarted <- newEmptyMVar + worker <- forkIO $ mask_ $ do + putMVar workerStarted () + (forever $ do + atomicModifyIORef' iters (\n -> (n + 1, ())) + _ <- c_pause + return ()) + `catch` (\(_ :: SomeException) -> return ()) + + takeMVar workerStarted + threadDelay 100_000 + + killer1Ready <- newEmptyMVar + killer1 <- forkIO $ do + putMVar killer1Ready () + killThread worker + + takeMVar killer1Ready + threadDelay 100_000 + + preRevoke <- readIORef iters + + killThread killer1 + + threadDelay postRevokeWindow + + postRevoke <- readIORef iters + let storm = postRevoke - preRevoke + if storm > postRevokeThreshold + then do + hPutStrLn stderr ("FAIL: post-revoke EINTR storm, iterations=" + ++ show storm + ++ " (pre=" ++ show preRevoke + ++ " post=" ++ show postRevoke ++ ")") + exitFailure + else + putStrLn ("ok (post-revoke iterations=" ++ show storm ++ ")") ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -208,11 +208,24 @@ test('foreignInterruptible', [when(fast(), skip), test('T27113', [when(opsys('mingw32'), skip), + only_threaded_ways, + req_c], + compile_and_run, ['T27113_c.c']) + +test('T27113b', + [extra_files(['T27113_c.c']), + when(opsys('mingw32'), skip), only_threaded_ways, req_c, - expect_broken(27113)], + ignore_stdout], compile_and_run, ['T27113_c.c']) +test('T27113c', + [when(opsys('mingw32'), skip), + only_threaded_ways, + ignore_stdout], + compile_and_run, ['']) + test('conc037', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) test('conc038', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daa651639f3768d11ea0f76cbb121c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daa651639f3768d11ea0f76cbb121c7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27113-retry] rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113)
by Zubin (＠wz1000) 19 May '26

19 May '26

Zubin pushed to branch wip/27113-retry at Glasgow Haskell Compiler / GHC Commits: 7c45db7a by Zubin Duggal at 2026-05-19T18:45:38+05:30 rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113) Closes a race in the threaded RTS where a SIGPIPE fired by throwTo to cancel an interruptible foreign call may land in the user-space prologue of the FFI wrapper, between suspendThread releasing the capability and the kernel syscall starting. GHC's empty SIGPIPE handler swallows the signal and the syscall then blocks forever. - - - - - 11 changed files: - rts/RaiseAsync.c - rts/Schedule.c - rts/Schedule.h - rts/Task.c - rts/Task.h - rts/Timer.c - testsuite/tests/concurrent/should_run/T27113.hs - testsuite/tests/concurrent/should_run/T27113_c.c - + testsuite/tests/concurrent/should_run/T27113b.hs - + testsuite/tests/concurrent/should_run/T27113c.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== rts/RaiseAsync.c ===================================== @@ -36,6 +36,11 @@ static void throwToSendMsg (Capability *cap USED_IF_THREADS, Capability *target_cap USED_IF_THREADS, MessageThrowTo *msg USED_IF_THREADS); +#if defined(THREADED_RTS) +static void clear_interrupt_pending_if_no_live_throw (Capability *cap, + StgTSO *target); +#endif + /* ----------------------------------------------------------------------------- throwToSingleThreaded @@ -338,7 +343,13 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + StgTSO *m_target = m->target; +#endif doneWithMsgThrowTo(cap, m); +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif raiseAsync(cap, target, msg->exception, false, NULL); return THROWTO_SUCCESS; @@ -433,11 +444,12 @@ check_target: #if defined(THREADED_RTS) { Task *task = NULL; - // walk suspended_ccalls to find the correct worker thread + InCall *target_incall = NULL; InCall *incall; for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) { if (incall->suspended_tso == target) { task = incall->task; + target_incall = incall; break; } } @@ -446,6 +458,7 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -520,8 +533,14 @@ blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) ASSERT(target->cap == cap); dirty_TSO(cap,target); // we will modify the blocked_exceptions queue +#if defined(THREADED_RTS) + ACQUIRE_LOCK(&cap->lock); +#endif msg->link = target->blocked_exceptions; - target->blocked_exceptions = msg; + RELEASE_STORE(&target->blocked_exceptions, msg); +#if defined(THREADED_RTS) + RELEASE_LOCK(&cap->lock); +#endif } /* ----------------------------------------------------------------------------- @@ -664,6 +683,46 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +static void +clear_interrupt_pending_if_no_live_throw (Capability *cap, StgTSO *target) +{ + if (target == NULL) return; + if (ACQUIRE_LOAD(&target->why_blocked) != BlockedOnCCall_Interruptible) + return; + + Capability *target_cap = ACQUIRE_LOAD(&target->cap); + ACQUIRE_LOCK(&target_cap->lock); + + // Find the InCall on target_cap. If target has already resumed (or + // wasn't really suspended on this cap), do nothing. + InCall *found = NULL; + for (InCall *ic = target_cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ic->suspended_tso == target) { found = ic; break; } + } + if (found == NULL) { + RELEASE_LOCK(&target_cap->lock); + return; + } + + bool live = false; + for (MessageThrowTo *t = ACQUIRE_LOAD(&target->blocked_exceptions); + t != END_BLOCKED_EXCEPTIONS_QUEUE; + t = (MessageThrowTo*)t->link) { + if (RELAXED_LOAD((StgWord*)&t->header.info) + != (StgWord)&stg_MSG_NULL_info) { + live = true; break; + } + } + if (!live) { + RELEASE_STORE(&found->interrupt_pending, 0); + } + + RELEASE_LOCK(&target_cap->lock); + (void)cap; +} +#endif + static void removeFromQueues(Capability *cap, StgTSO *tso) { @@ -699,8 +758,16 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + StgTSO *m_target = m->target; +#endif + // unlock and revoke it at the same time doneWithMsgThrowTo(cap, m); + +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif break; } ===================================== rts/Schedule.c ===================================== @@ -2536,6 +2536,25 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + if (interruptible + && !((tso->flags & TSO_BLOCKEX) && + ((tso->flags & TSO_INTERRUPTIBLE) == 0))) { + MessageThrowTo *head = ACQUIRE_LOAD(&tso->blocked_exceptions); + bool live = false; + for (MessageThrowTo *m = head; + m != END_BLOCKED_EXCEPTIONS_QUEUE; + m = (MessageThrowTo*)m->link) { + if (RELAXED_LOAD((StgWord*)&m->header.info) + != (StgWord)&stg_MSG_NULL_info) { live = true; break; } + } + if (live) { + RELEASE_STORE(&task->incall->interrupt_pending, 1); + } + } +#endif + releaseCapability_(cap,false); RELEASE_LOCK(&cap->lock); @@ -2574,8 +2593,10 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + ACQUIRE_LOCK(&cap->lock); + RELEASE_STORE(&incall->interrupt_pending, 0); recoverSuspendedTask(cap,task); + RELEASE_LOCK(&cap->lock); tso = incall->suspended_tso; incall->suspended_tso = NULL; @@ -2614,6 +2635,31 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +void +retryInterruptibleSignals(void) +{ + bool any_pending = false; + uint32_t n = getNumCapabilities(); + for (uint32_t i = 0; i < n; i++) { + Capability *cap = getCapability(i); + if (RELAXED_LOAD(&cap->n_suspended_ccalls) == 0) continue; + if (TRY_ACQUIRE_LOCK(&cap->lock) != 0) continue; + for (InCall *ic = cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ACQUIRE_LOAD(&ic->interrupt_pending) == 0) continue; + // ic->task is set by newInCall and never cleared. + if (ic->task != NULL) { + any_pending = true; + interruptOSThread(ic->task->id); + } + } + RELEASE_LOCK(&cap->lock); + } + // Keep the timer alive; handle_tick's idle path would otherwise stop it. + if (any_pending) setRecentActivity(ACTIVITY_YES); +} +#endif + /* --------------------------------------------------------------------------- * scheduleThread() * ===================================== rts/Schedule.h ===================================== @@ -43,6 +43,10 @@ void scheduleThreadOn(Capability *cap, StgWord cpu, StgTSO *tso); void wakeUpRts(void); #endif +#if defined(THREADED_RTS) +void retryInterruptibleSignals(void); +#endif + /* raiseExceptionHelper */ StgWord raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception); ===================================== rts/Task.c ===================================== @@ -267,6 +267,7 @@ newInCall (Task *task) incall->next = NULL; incall->prev = NULL; incall->prev_stack = task->incall; + incall->interrupt_pending = 0; task->incall = incall; } ===================================== rts/Task.h ===================================== @@ -106,6 +106,8 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,9 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + if (SEQ_CST_LOAD_ALWAYS(&timer_disabled) == 0) { + retryInterruptibleSignals(); + } #endif /* ===================================== testsuite/tests/concurrent/should_run/T27113.hs ===================================== @@ -10,7 +10,7 @@ import System.IO import System.Timeout foreign import ccall interruptible "cpu_then_pause" - c_cpu_then_pause :: CLong -> IO () + c_cpu_then_pause :: CLLong -> IO () killDelay :: Int killDelay = 200_000 @@ -18,7 +18,7 @@ killDelay = 200_000 joinTimeout :: Int joinTimeout = 3_000_000 -runCase :: String -> CLong -> IO () +runCase :: String -> CLLong -> IO () runCase name spinNs = do tid <- forkIO $ c_cpu_then_pause spinNs ===================================== testsuite/tests/concurrent/should_run/T27113_c.c ===================================== @@ -1,17 +1,18 @@ #include <errno.h> +#include <stdint.h> #include <time.h> #include <unistd.h> -static long now_ns(void) { +static int64_t now_ns(void) { struct timespec t; while (clock_gettime(CLOCK_MONOTONIC, &t) != 0) { if (errno != EINTR) return 0; } - return (long)t.tv_sec * 1000000000L + (long)t.tv_nsec; + return (int64_t)t.tv_sec * 1000000000LL + (int64_t)t.tv_nsec; } -int cpu_then_pause(long spin_ns) { - long deadline = now_ns() + spin_ns; +int cpu_then_pause(int64_t spin_ns) { + int64_t deadline = now_ns() + spin_ns; while (now_ns() < deadline) { } return pause(); ===================================== testsuite/tests/concurrent/should_run/T27113b.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Foreign.C.Types +import System.IO +import System.Timeout + +foreign import ccall interruptible "cpu_then_pause" + c_cpu_then_pause :: CLLong -> IO () + +-- Recommended pattern: under mask, with allowInterrupt as the explicit +-- interruption point. After a SIGPIPE-driven pause EINTR, control +-- returns to Haskell still under mask, so the queued throw isn't +-- delivered until allowInterrupt. For the kill to complete, the SIGPIPE +-- retry must fire when the initial SIGPIPE is lost in the user-space +-- prologue (the spin loop) — otherwise pause blocks forever and +-- killThread hangs. +myCall :: CLLong -> IO () +myCall spinNs = mask_ $ do + allowInterrupt + c_cpu_then_pause spinNs + allowInterrupt + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + started <- newEmptyMVar + done <- newEmptyMVar + -- mask_ around the forkIOWithUnmask ensures the child inherits + -- MaskedInterruptible, so finally is set up before our killThread + -- below can be delivered. + tid <- mask_ $ forkIOWithUnmask $ \unmask -> + flip finally (putMVar done ()) $ do + putMVar started () + unmask (myCall 2_000_000_000) + `catch` (\(_ :: SomeException) -> return ()) + takeMVar started + threadDelay 200_000 + result <- timeout 5_000_000 (killThread tid >> takeMVar done) + case result of + Just () -> putStrLn "ok" + Nothing -> do + hPutStrLn stderr "FAIL: killThread hung" + error "hung" ===================================== testsuite/tests/concurrent/should_run/T27113c.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import Foreign.C.Types +import System.Exit +import System.IO + +foreign import ccall interruptible "pause" c_pause :: IO CInt + +postRevokeWindow :: Int +postRevokeWindow = 2_000_000 + +postRevokeThreshold :: Int +postRevokeThreshold = 5 + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + iters <- newIORef (0 :: Int) + + workerStarted <- newEmptyMVar + worker <- forkIO $ mask_ $ do + putMVar workerStarted () + (forever $ do + atomicModifyIORef' iters (\n -> (n + 1, ())) + _ <- c_pause + return ()) + `catch` (\(_ :: SomeException) -> return ()) + + takeMVar workerStarted + threadDelay 100_000 + + killer1Ready <- newEmptyMVar + killer1 <- forkIO $ do + putMVar killer1Ready () + killThread worker + + takeMVar killer1Ready + threadDelay 100_000 + + preRevoke <- readIORef iters + + killThread killer1 + + threadDelay postRevokeWindow + + postRevoke <- readIORef iters + let storm = postRevoke - preRevoke + if storm > postRevokeThreshold + then do + hPutStrLn stderr ("FAIL: post-revoke EINTR storm, iterations=" + ++ show storm + ++ " (pre=" ++ show preRevoke + ++ " post=" ++ show postRevoke ++ ")") + exitFailure + else + putStrLn ("ok (post-revoke iterations=" ++ show storm ++ ")") ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -208,11 +208,24 @@ test('foreignInterruptible', [when(fast(), skip), test('T27113', [when(opsys('mingw32'), skip), + only_threaded_ways, + req_c], + compile_and_run, ['T27113_c.c']) + +test('T27113b', + [extra_files(['T27113_c.c']), + when(opsys('mingw32'), skip), only_threaded_ways, req_c, - expect_broken(27113)], + ignore_stdout], compile_and_run, ['T27113_c.c']) +test('T27113c', + [when(opsys('mingw32'), skip), + only_threaded_ways, + ignore_stdout], + compile_and_run, ['']) + test('conc037', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) test('conc038', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c45db7a591fc6bb1d3589689611cf0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c45db7a591fc6bb1d3589689611cf0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] 2 commits: Disable `GHC.Internal.Unicode.Version` import for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 967b23cb by Wolfgang Jeltsch at 2026-05-19T16:04:36+03:00 Disable `GHC.Internal.Unicode.Version` import for GHC 9.14 - - - - - 025d47d3 by Wolfgang Jeltsch at 2026-05-19T16:06:14+03:00 Disable GHC 9.14 `printToHandleFinalizerExceptionHandler` - - - - - 3 changed files: - libraries/base/src/GHC/Unicode.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs Changes: ===================================== libraries/base/src/GHC/Unicode.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} @@ -44,4 +45,6 @@ module GHC.Unicode ) where import GHC.Internal.Unicode +#if __GLASGOW_HASKELL__ >= 1000 import GHC.Internal.Unicode.Version +#endif ===================================== libraries/base/src/GHC/Weak.hs ===================================== @@ -25,9 +25,8 @@ module GHC.Weak -- this handler will be ignored. setFinalizerExceptionHandler, getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler + GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler ) where import GHC.Internal.Weak -import GHC.Internal.Weak.Finalize import GHC.Weak.Finalize ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -7,7 +7,7 @@ module GHC.Weak.Finalize -- this handler will be ignored. setFinalizerExceptionHandler , getFinalizerExceptionHandler - , printToHandleFinalizerExceptionHandler + , GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler -- * Internal , GHC.Weak.Finalize.runFinalizerBatch ) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b404918e10366d02345cd3d4d850a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b404918e10366d02345cd3d4d850a… You're receiving this email because of your account on gitlab.haskell.org.

1 0