- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/jeltsch/ghc-desugar-removal
by Wolfgang Jeltsch (＠jeltsch) 26 Jan '26

26 Jan '26

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

1 0

[Git][ghc/ghc][wip/T26830] ghc-internal: move all Data instances to Data.Data
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed to branch wip/T26830 at Glasgow Haskell Compiler / GHC Commits: 15b48aca by Teo Camarasu at 2026-01-26T20:10:40+00:00 ghc-internal: move all Data instances to Data.Data Most instances of Data are defined in GHC.Internal.Data.Data. Let's move all remaining instance there. This moves other modules down in the dependency hierarchy allowing for more parallelism, and it decreases the likelihood that we would need to load this heavy .hi file if we don't actually need it. Resolves #26830 Metric Decrease: T12227 T16875 - - - - - 9 changed files: - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Data.hs ===================================== @@ -144,6 +144,8 @@ import qualified GHC.Internal.Generics as Generics (Fixity(..)) import GHC.Internal.Generics hiding (Fixity(..)) -- So we can give Data instance for U1, V1, ... import qualified GHC.Internal.TH.Syntax as TH +import GHC.Internal.Functor.ZipList (ZipList(..)) +import GHC.Internal.Exts (SpecConstrAnnotation(..)) ------------------------------------------------------------------------------ -- @@ -1414,3 +1416,9 @@ deriving instance Data TH.TySynEqn deriving instance Data TH.Type deriving instance Data TH.TypeFamilyHead deriving instance Data flag => Data (TH.TyVarBndr flag) + +-- | @since base-4.14.0.0 +deriving instance Data a => Data (ZipList a) + +-- | @since base-4.3.0.0 +deriving instance Data SpecConstrAnnotation ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -5,7 +5,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE Unsafe #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- @@ -317,7 +316,6 @@ import GHC.Internal.IsList (IsList(..)) -- for re-export import qualified GHC.Internal.Data.Coerce import GHC.Internal.Data.String import GHC.Internal.Data.OldList -import GHC.Internal.Data.Data import GHC.Internal.Data.Ord import qualified GHC.Internal.Debug.Trace import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export @@ -384,8 +382,7 @@ traceEvent = GHC.Internal.Debug.Trace.traceEventIO -- entire ghc package at runtime data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr - deriving ( Data -- ^ @since base-4.3.0.0 - , Eq -- ^ @since base-4.3.0.0 + deriving ( Eq -- ^ @since base-4.3.0.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs ===================================== @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveDataTypeable #-} module GHC.Internal.Functor.ZipList (ZipList(..)) where @@ -14,7 +13,6 @@ import GHC.Internal.Read (Read) import GHC.Internal.Show (Show) import GHC.Internal.Data.Foldable (Foldable) import GHC.Internal.Data.Traversable (Traversable(..)) -import GHC.Internal.Data.Data (Data) -- | Lists, but with an 'Applicative' functor based on zipping. -- @@ -76,7 +74,3 @@ instance Alternative ZipList where go (x:xs) (_:ys) = x : go xs ys go [] ys = ys go xs _ = xs - --- | @since base-4.14.0.0 -deriving instance Data a => Data (ZipList a) - ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11591,7 +11591,6 @@ instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’ instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’ -instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Functor.ZipList’ instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’ instance forall s. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable s => GHC.Internal.Data.Data.Data (Data.Array.Byte.MutableByteArray s) -- Defined in ‘Data.Array.Byte’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ @@ -11694,6 +11693,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceStrictness -- instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceStrictness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ +instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Specificity -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Stmt -- Defined in ‘GHC.Internal.Data.Data’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Data.Semigroup.Internal.Sum a) -- Defined in ‘GHC.Internal.Data.Data’ @@ -11719,6 +11719,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word32 -- Defined in ‘G instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word64 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word8 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Data.Data’ +instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Data.Data’ instance forall k (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a) => GHC.Internal.Data.Data.Data (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ instance forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k1, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k2, GHC.Internal.Data.Data.Data (f (g a))) => GHC.Internal.Data.Data.Data (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance [safe] forall k (f :: k -> *) (g :: k -> *) (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, GHC.Internal.Data.Data.Data (f a), GHC.Internal.Data.Data.Data (g a)) => GHC.Internal.Data.Data.Data (Data.Functor.Product.Product f g a) -- Defined in ‘Data.Functor.Product’ @@ -11729,7 +11730,6 @@ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Data.Data.Data m => GHC.Internal.Data.Data.Data (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall m. GHC.Internal.Data.Foldable.Foldable (GHC.Internal.Data.Functor.Const.Const m) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance GHC.Internal.Data.Foldable.Foldable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Foldable.Foldable f, GHC.Internal.Data.Foldable.Foldable g) => GHC.Internal.Data.Foldable.Foldable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Foldable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -11618,7 +11618,6 @@ instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’ instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’ -instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Functor.ZipList’ instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’ instance forall s. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable s => GHC.Internal.Data.Data.Data (Data.Array.Byte.MutableByteArray s) -- Defined in ‘Data.Array.Byte’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ @@ -11721,6 +11720,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceStrictness -- instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceStrictness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ +instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Specificity -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Stmt -- Defined in ‘GHC.Internal.Data.Data’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Data.Semigroup.Internal.Sum a) -- Defined in ‘GHC.Internal.Data.Data’ @@ -11746,6 +11746,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word32 -- Defined in ‘G instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word64 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word8 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Data.Data’ +instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Data.Data’ instance forall k (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a) => GHC.Internal.Data.Data.Data (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ instance forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k1, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k2, GHC.Internal.Data.Data.Data (f (g a))) => GHC.Internal.Data.Data.Data (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance [safe] forall k (f :: k -> *) (g :: k -> *) (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, GHC.Internal.Data.Data.Data (f a), GHC.Internal.Data.Data.Data (g a)) => GHC.Internal.Data.Data.Data (Data.Functor.Product.Product f g a) -- Defined in ‘Data.Functor.Product’ @@ -11756,7 +11757,6 @@ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Data.Data.Data m => GHC.Internal.Data.Data.Data (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall m. GHC.Internal.Data.Foldable.Foldable (GHC.Internal.Data.Functor.Const.Const m) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance GHC.Internal.Data.Foldable.Foldable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Foldable.Foldable f, GHC.Internal.Data.Foldable.Foldable g) => GHC.Internal.Data.Foldable.Foldable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Foldable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11849,7 +11849,6 @@ instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’ instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’ -instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Functor.ZipList’ instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’ instance forall s. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable s => GHC.Internal.Data.Data.Data (Data.Array.Byte.MutableByteArray s) -- Defined in ‘Data.Array.Byte’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ @@ -11952,6 +11951,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceStrictness -- instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceStrictness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ +instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Specificity -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Stmt -- Defined in ‘GHC.Internal.Data.Data’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Data.Semigroup.Internal.Sum a) -- Defined in ‘GHC.Internal.Data.Data’ @@ -11977,6 +11977,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word32 -- Defined in ‘G instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word64 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word8 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Data.Data’ +instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Data.Data’ instance forall k (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a) => GHC.Internal.Data.Data.Data (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ instance forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k1, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k2, GHC.Internal.Data.Data.Data (f (g a))) => GHC.Internal.Data.Data.Data (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance [safe] forall k (f :: k -> *) (g :: k -> *) (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, GHC.Internal.Data.Data.Data (f a), GHC.Internal.Data.Data.Data (g a)) => GHC.Internal.Data.Data.Data (Data.Functor.Product.Product f g a) -- Defined in ‘Data.Functor.Product’ @@ -11987,7 +11988,6 @@ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Data.Data.Data m => GHC.Internal.Data.Data.Data (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall m. GHC.Internal.Data.Foldable.Foldable (GHC.Internal.Data.Functor.Const.Const m) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance GHC.Internal.Data.Foldable.Foldable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Foldable.Foldable f, GHC.Internal.Data.Foldable.Foldable g) => GHC.Internal.Data.Foldable.Foldable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Foldable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11591,7 +11591,6 @@ instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’ instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’ -instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Functor.ZipList’ instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’ instance forall s. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable s => GHC.Internal.Data.Data.Data (Data.Array.Byte.MutableByteArray s) -- Defined in ‘Data.Array.Byte’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ @@ -11694,6 +11693,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceStrictness -- instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceStrictness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Data.Data’ +instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Specificity -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.TH.Syntax.Stmt -- Defined in ‘GHC.Internal.Data.Data’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Data.Semigroup.Internal.Sum a) -- Defined in ‘GHC.Internal.Data.Data’ @@ -11719,6 +11719,7 @@ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word32 -- Defined in ‘G instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word64 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Word.Word8 -- Defined in ‘GHC.Internal.Data.Data’ instance GHC.Internal.Data.Data.Data GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Data.Data’ +instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Data.Data’ instance forall k (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a) => GHC.Internal.Data.Data.Data (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ instance forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k1, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k2, GHC.Internal.Data.Data.Data (f (g a))) => GHC.Internal.Data.Data.Data (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance [safe] forall k (f :: k -> *) (g :: k -> *) (a :: k). (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable f, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable g, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable k, GHC.Internal.Data.Data.Data (f a), GHC.Internal.Data.Data.Data (g a)) => GHC.Internal.Data.Data.Data (Data.Functor.Product.Product f g a) -- Defined in ‘Data.Functor.Product’ @@ -11729,7 +11730,6 @@ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Data.Data.Data a => GHC.Internal.Data.Data.Data (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Data.Data.Data m => GHC.Internal.Data.Data.Data (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall m. GHC.Internal.Data.Foldable.Foldable (GHC.Internal.Data.Functor.Const.Const m) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance GHC.Internal.Data.Foldable.Foldable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Foldable.Foldable f, GHC.Internal.Data.Foldable.Foldable g) => GHC.Internal.Data.Foldable.Foldable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Foldable’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -11186,7 +11186,6 @@ instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.FunPtr a) -- Defin instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.Ptr a) -- Defined in ‘GHC.Internal.Ptr’ instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Classes.Ord GHC.Internal.Base.Void -- Defined in ‘GHC.Internal.Base’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -11189,7 +11189,6 @@ instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.FunPtr a) -- Defin instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.Ptr a) -- Defined in ‘GHC.Internal.Ptr’ instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Classes.Ord GHC.Internal.Base.Void -- Defined in ‘GHC.Internal.Base’ -instance GHC.Internal.Data.Data.Data GHC.Internal.Exts.SpecConstrAnnotation -- Defined in ‘GHC.Internal.Exts’ instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15b48aca8435ad4f92b83d320762498… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15b48aca8435ad4f92b83d320762498… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] WIP fixes
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: e7146154 by sheaf at 2026-01-26T20:42:55+01:00 WIP fixes - - - - - 5 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Types/Tickish.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -935,7 +935,12 @@ lintCoreExpr (Tick tickish expr) -- ; when block_joins ; pure r} where - block_joins = not (tickishCanScopeJoin tickish) + block_joins + | ProfNote {} <- tickish + = False -- Turns a true join point into a quasi join point. + -- SLD TODO: proper Core Lint support for quasi join points. + | otherwise + = not (tickishCanScopeJoin tickish) -- TODO Consider whether this is the correct rule. It is consistent with -- the simplifier's behaviour - cost-centre-scoped ticks become part of -- the continuation, and thus they behave like part of an evaluation ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -226,7 +226,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid TrueJoinPoint (length abs_vars) rhs + ; v <- addExit avoid (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -273,11 +273,11 @@ mkExitJoinId in_scope ty join_ty join_arity = do asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) join_ty join_arity -addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_ty join_arity rhs = do +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty join_ty join_arity + v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity fs <- get put ((v,rhs):fs) return v ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2299,7 +2299,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllNonTail usage2 -- SLD TODO: markAllQuasiTail but this prevenst GHC bootstrapping + usage3 = markAllQuasiTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2611,7 +2611,7 @@ occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllNonTail usage1 -- SLD TODO: markAllQuasiTail but this prevenst GHC bootstrapping + usage2 = markAllQuasiTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -3874,8 +3874,10 @@ markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccIn markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = fmap (const MarkNonTail) env } -markAllQuasiTail ud@(UD { ud_env = env }) = - ud { ud_z_tail = fmap (const MarkQuasi) env } +markAllQuasiTail ud@(UD { ud_env = env, ud_z_tail = z_tail }) = + let quasis = fmap (const MarkQuasi) env + in ud { ud_z_tail = strictPlusVarEnv_C (Semi.<>) quasis z_tail } + -- NB: be careful not to override any MarkNonTail with MarkQuasi. markAllInsideLamIf, markAllNonTailIf :: HasDebugCallStack => Bool -> UsageDetails -> UsageDetails ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2134,9 +2134,11 @@ trimJoinCont :: Id -- Used only in error message trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont - = assertPpr (join_ty == TrueJoinPoint) - (text "trimJoinCont: unexpected quasi join point:" <+> ppr var) $ - trim arity cont + | QuasiJoinPoint <- join_ty + -- SLD TODO: not sure why we can end up here. Needs further investigation. + = cont + | otherwise + = trim arity cont where trim 0 cont@(Stop {}) = cont ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -330,7 +330,8 @@ tickishCanSplit _ = False -- | Is @join f x in <tick> jump f x@ valid? tickishCanScopeJoin :: GenTickish pass -> Bool tickishCanScopeJoin tick = case tick of - ProfNote{} -> True + ProfNote{} -> False -- Turns the join point into a quasi join point. + -- See Note [Quasi join points] HpcTick{} -> False Breakpoint{} -> False SourceNote{} -> True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7146154eb711d91c03f703fbdf83d7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7146154eb711d91c03f703fbdf83d7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] 2 commits: WIP: refactoring
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 425073c8 by sheaf at 2026-01-26T20:00:08+01:00 WIP: refactoring - - - - - 591bc759 by sheaf at 2026-01-26T20:26:19+01:00 WIP fixes - - - - - 19 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -935,7 +935,12 @@ lintCoreExpr (Tick tickish expr) -- ; when block_joins ; pure r} where - block_joins = not (tickishCanScopeJoin tickish) + block_joins + | ProfNote {} <- tickish + = False -- Turns a true join point into a quasi join point. + -- SLD TODO: proper Core Lint support for quasi join points. + | otherwise + = not (tickishCanScopeJoin tickish) -- TODO Consider whether this is the correct rule. It is consistent with -- the simplifier's behaviour - cost-centre-scoped ticks become part of -- the continuation, and thus they behave like part of an evaluation @@ -1021,22 +1026,27 @@ lintCoreExpr e@(App _ _) ; return app_pair} where - skipTick t = case collectFunSimple e of - (Var v) -> etaExpansionTick v t - _ -> tickishFloatable t - (fun, args, _source_ticks) = collectArgsTicks skipTick e - -- We must look through source ticks to avoid #21152, for example: + skipTick t = + case collectFunSimple e of + Var v -> canCollectArgsThroughTick v t + _ -> tickishFloatable t + (fun, args, _ticks) = collectArgsTicks skipTick e + -- We must look through ticks, using similar logic as CorePrep does, + -- otherwise we may fail to spot a saturated application. + -- + -- 1. Look through floatable ticks, as per Note [Eta expansion and source notes] + -- in GHC.Core.Opt.Arity. We need to do this to avoid e.g.: + -- + -- reallyUnsafePtrEquality + -- = \ @a -> + -- (src<loc> reallyUnsafePtrEquality#) + -- @Lifted @a @Lifted @a -- - -- reallyUnsafePtrEquality - -- = \ @a -> - -- (src<loc> reallyUnsafePtrEquality#) - -- @Lifted @a @Lifted @a + -- 2. Look through profiling ticks when the head of the application must + -- always remain saturated (e.g. a primop or a join point), as per + -- Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep. -- - -- To do this, we use `collectArgsTicks tickishFloatable` to match - -- the eta expansion behaviour, as per Note [Eta expansion and source notes] - -- in GHC.Core.Opt.Arity. - -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. - -- See Note [Ticks and mandatory eta expansion] + -- To do this, we use 'canCollectArgsThroughTick', as CorePrep does. lintCoreExpr (Lam var expr) = markAllJoinsBad $ ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -226,7 +226,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid TrueJoinPoint (length abs_vars) rhs + ; v <- addExit avoid (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -262,7 +262,7 @@ exitifyRec in_scope pairs -- * the free variables of the whole joinrec -- * any bound variables (captured) -- * any exit join points created so far. -mkExitJoinId :: InScopeSet -> Type -> JoinType -> JoinArity -> ExitifyM JoinId +mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId mkExitJoinId in_scope ty join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) @@ -273,11 +273,11 @@ mkExitJoinId in_scope ty join_ty join_arity = do asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) join_ty join_arity -addExit :: InScopeSet -> JoinType -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_ty join_arity rhs = do +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty join_ty join_arity + v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity fs <- get put ((v,rhs):fs) return v ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1126,7 +1126,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS - WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ + WUD adj_rhs_uds final_rhs = adjustNonRecRhs (joinPointHoodArity mb_join) $ occAnalLamTail rhs_env rhs final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] @@ -1140,7 +1140,8 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- See Note [Join points and unfoldings/rules] unf = idUnfolding bndr WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf - adj_unf_uds = adjustTailArity mb_join unf_tuds + adj_unf_uds = adjustTailArity mb_join_arity unf_tuds + mb_join_arity = joinPointHoodArity mb_join --------- Rules --------- -- See Note [Rules are extra RHSs] and Note [Rule dependency info] @@ -1160,7 +1161,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs adj_rule_uds :: [UsageDetails] adj_rule_uds = imp_rule_uds ++ - [ l `andUDs` adjustTailArity mb_join r + [ l `andUDs` adjustTailArity mb_join_arity r | (_,l,r) <- rules_w_uds ] mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl @@ -1215,7 +1216,7 @@ occAnalRec !_ lvl = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds + !(WUD rhs_uds' rhs') = adjustNonRecRhs (joinPointHoodArity mb_join) wtuds in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -1831,7 +1832,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness -- here because that is what we are setting! WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf - adj_unf_uds = adjustTailArity (JoinPoint True rhs_ja) unf_tuds + adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source MAr -- of Note [Join arity prediction based on joinRhsArity] @@ -1846,7 +1847,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source MAr -- of Note [Join arity prediction based on joinRhsArity] rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = [ (r,l,adjustTailArity (JoinPoint True rhs_ja) rhs_wuds) + rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_wuds) | rule <- idCoreRules bndr , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ] rules' = map fstOf3 rules_w_uds @@ -2298,7 +2299,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllQuasiTail usage2 + usage3 = markAllQuasiTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2606,19 +2607,11 @@ occAnal env (Tick tickish body) usage_lam = markAllNonTail (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick<t> (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. - occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllQuasiTail usage1 + usage2 = markAllQuasiTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -2626,7 +2619,7 @@ occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) occAnal env expr@(Lam {}) - = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail + = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail occAnalLamTail env expr occAnal env (Case scrut bndr ty alts) @@ -2754,7 +2747,8 @@ occAnalApp env (Var fun, args, ticks) -- This caused #18296 | fun `hasKey` runRWKey , [t1, t2, arg] <- args - , WUD usage arg' <- adjustNonRecRhs (JoinPoint True 1) $ occAnalLamTail env arg + , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg + -- SLD TODO TrueJoinPoint OK here?? = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out @@ -3814,8 +3808,8 @@ mkOneOcc !env id int_cxt arity , lo_tail = AlwaysTailCalled { tailCallArity = arity - , trueTailCall = True - -- ^ Start off as a true join point. + , tailCallJoinPointType = TrueJoinPoint + -- Start off as a true join point. -- Updated by occurrence analysis. -- -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. @@ -3903,7 +3897,11 @@ maybeZapTailCallInfo tail_info0 z_tail id_unique = Just MarkNonTail -> NoTailCallInfo -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - Just MarkQuasi -> tail_info0 { trueTailCall = False } + Just MarkQuasi -> + case tail_info0 of + NoTailCallInfo -> NoTailCallInfo + atc@AlwaysTailCalled {} -> + atc { tailCallJoinPointType = QuasiJoinPoint } Nothing -> tail_info0 @@ -3974,7 +3972,7 @@ lookupOccInfoByUnique (UD { ud_env = env ------------------- -- See Note [Adjusting right-hand sides] -adjustNonRecRhs :: JoinPointHood +adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the @@ -3985,8 +3983,8 @@ adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) where exact_join = case mb_join_arity of - NotJoinPoint -> False - JoinPoint { joinPointArity = ja' } -> ja' == rhs_ja + Nothing -> False + Just ja' -> ja' == rhs_ja adjustTailUsage :: Bool -- True <=> Exactly-matching join point; don't do markNonTail -> CoreExpr -- Rhs usage, AFTER occAnalLamTail @@ -4000,12 +3998,12 @@ adjustTailUsage exact_join rhs uds where one_shot = isOneShotFun rhs -adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails +adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf not_same_arity usage where not_same_arity = case mb_rhs_ja of - NotJoinPoint -> True - JoinPoint { joinPointArity = ja' } -> ja' /= ja + Nothing -> True + Just ja' -> ja' /= ja type IdWithOccInfo = Id @@ -4037,8 +4035,11 @@ tagNonRecBinder :: TopLevelFlag -- At top level? -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr | okForJoinPoint lvl bndr tail_call_info - , AlwaysTailCalled { tailCallArity = ar, trueTailCall = true } <- tail_call_info - = (setBinderOcc occ bndr, JoinPoint true ar) + , AlwaysTailCalled + { tailCallArity = ar + , tailCallJoinPointType = join_ty + } <- tail_call_info + = (setBinderOcc occ bndr, JoinPoint join_ty ar) | otherwise = (setBinderOcc zapped_occ bndr, NotJoinPoint) where @@ -4229,5 +4230,5 @@ orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2 andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo (AlwaysTailCalled arity1 true1) (AlwaysTailCalled arity2 true2) - | arity1 == arity2 = AlwaysTailCalled arity1 (true1 && true2) + | arity1 == arity2 = AlwaysTailCalled arity1 (true1 Semi.<> true2) andTailCallInfo _ _ = NoTailCallInfo ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -1889,11 +1889,10 @@ newPolyBndrs dest_lvl dest_is_top = isTopLvl dest_lvl transfer_join_info bndr new_bndr | JoinPoint - { isTrueJoinPoint = true_join + { joinPointType = join_ty , joinPointArity = join_arity } <- idJoinPointHood bndr , not dest_is_top - , let join_ty = if true_join then TrueJoinPoint else QuasiJoinPoint = asJoinId new_bndr join_ty ( join_arity + length abs_vars ) ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -493,8 +493,8 @@ instance Outputable SimplSR where where pp_mj = case mj of NotJoinPoint -> empty - JoinPoint true_join n - -> (if true_join then empty else text "[Quasi]") <> parens (int n) + JoinPoint { joinPointType = join_ty, joinPointArity = n } + -> ppr join_ty <> parens (int n) ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2073,7 +2073,7 @@ simplNonRecJoinPoint env bndr rhs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case - | Just True <- occInfoIsTrueJoinPoint (idOccInfo bndr) + | Just TrueJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) = seCaseCase env | otherwise = False @@ -2094,7 +2094,7 @@ simplRecJoinPoint env pairs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case = - if all ((== Just True) . occInfoIsTrueJoinPoint . idOccInfo . fst) pairs + if all ((== Just TrueJoinPoint) . occInfoJoinPointType_maybe . idOccInfo . fst) pairs then seCaseCase env else False @@ -2133,10 +2133,12 @@ trimJoinCont :: Id -- Used only in error message trimJoinCont _ NotJoinPoint cont = cont -- Not a jump -trimJoinCont var (JoinPoint { isTrueJoinPoint = true_join, joinPointArity = arity }) cont - = assertPpr true_join - (text "trimJoinCont: unexpected quasi join point:" <+> ppr var) $ - trim arity cont +trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont + | QuasiJoinPoint <- join_ty + -- SLD TODO: not sure why we can end up here. Needs further investigation. + = cont + | otherwise + = trim arity cont where trim 0 cont@(Stop {}) = cont @@ -2246,7 +2248,7 @@ Note [Join points and case-of-case]: This transformation is not valid if the occurrences of 'j' in 'body' appear: 1. under casts (see #26422) - 2. under profiling ticks (see #26693, #26157, #26642) + 2. under profiling ticks (see #14242, #26157, #26642, #26693) For example, consider (a minimisation of) the program in #26693: @@ -2312,7 +2314,7 @@ we proceed as follows: 2. In the simplifier, when we come across a join point binding (in either 'simplNonRecJoinPoint' or 'simplRecJoinPoint'), we retrieve the information of whether this is a true join point or a quasi join point using - 'occInfoIsTrueJoinPoint'. + 'occInfoJoinPointType_maybe'. If we are dealing with a quasi join point, we switch off the case-of-case transformation. ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Prelude import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) -import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo, JoinType (..) ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) import GHC.Core.Opt.Stats import GHC.Core.Rules ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -46,7 +46,7 @@ import GHC.Types.InlinePragma import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id -import GHC.Types.Id.Info ( IdDetails(..), JoinType (..) ) +import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -1993,9 +1993,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) spec_id_ty = mkLamTypes spec_lam_args spec_body_ty spec_arity = count isId spec_lam_args spec_join_arity - | Just ty <- joinId_maybe fn - , let is_true = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False } - = JoinPoint { isTrueJoinPoint = is_true, joinPointArity = length spec_call_args } + | Just join_ty <- joinId_maybe fn + = JoinPoint { joinPointType = join_ty, joinPointArity = length spec_call_args } | otherwise = NotJoinPoint spec_id = setCbvCandidate $ ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -844,10 +844,10 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div -- inl_rule: it does not make sense for workers to be constructorlike. work_join_arity - | Just ty <- joinId_maybe fn_id = - let true_join = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False } - in JoinPoint true_join join_arity - | otherwise = NotJoinPoint + | Just join_ty <- joinId_maybe fn_id + = JoinPoint join_ty join_arity + | otherwise + = NotJoinPoint -- worker is join point iff wrapper is join point -- (see Note [Don't w/w join points for CPR]) ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -308,13 +308,21 @@ ppr_expr add_par (Let bind expr) sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), pprCoreExpr expr] where - keyword (NonRec b _) - | isJoinPoint (bndrIsJoin_maybe b) = text "join" - | otherwise = text "let" - keyword (Rec pairs) - | ((b,_):_) <- pairs - , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec" - | otherwise = text "letrec" + keyword (NonRec b _) = + case bndrIsJoin_maybe b of + NotJoinPoint -> text "let" + JoinPoint { joinPointType = join_ty } -> + case join_ty of + TrueJoinPoint -> text "join" + QuasiJoinPoint -> text "quasijoin" + keyword (Rec ((b,_):_)) = + case bndrIsJoin_maybe b of + NotJoinPoint -> text "letrec" + JoinPoint { joinPointType = join_ty } -> + case join_ty of + TrueJoinPoint -> text "joinrec" + QuasiJoinPoint -> text "quasijoinrec" + keyword (Rec _) = text "letrec" ppr_expr add_par (Tick tickish expr) = sdocOption sdocSuppressTicks $ \case ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -38,7 +38,10 @@ import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Types.Literal import GHC.Types.Id -import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..), JoinType (..) ) +import GHC.Types.Id.Info + ( IdInfo(..) + , realUnfoldingInfo, setUnfoldingInfo, setRuleInfo + ) import GHC.Types.InlinePragma ( isAlwaysActive ) import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set @@ -1078,12 +1081,11 @@ joinPointBinding_maybe bndr rhs | AlwaysTailCalled { tailCallArity = join_arity - , trueTailCall = is_true_tail } + , tailCallJoinPointType = join_ty } <- tailCallInfo (idOccInfo bndr) , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs , let str_sig = idDmdSig bndr str_arity = count isId bndrs -- Strictness demands are for Ids only - join_ty = if is_true_tail then TrueJoinPoint else QuasiJoinPoint join_bndr = (asJoinId bndr join_ty join_arity) `setIdDmdSig` etaConvertDmdSig str_arity str_sig ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Core.Utils ( exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, exprIsUnaryClassFun, isUnaryClassId, - altsAreExhaustive, etaExpansionTick, + altsAreExhaustive, canCollectArgsThroughTick, cantEtaReduceFun, -- * Equality @@ -2076,14 +2076,17 @@ altsAreExhaustive (Alt con1 _ _ : alts) -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment --- | Should we look past this tick when eta-expanding the given function? +-- | Should we look past this tick when collecting arguments +-- for the given function? -- -- See Note [Ticks and mandatory eta expansion] --- Takes the function we are applying as argument. -etaExpansionTick :: Id -> GenTickish pass -> Bool -etaExpansionTick id t - = ( cantEtaReduceFun id ) && - ( tickishFloatable t || isProfTick t ) +canCollectArgsThroughTick + :: Id -- ^ function at the head of the application + -> GenTickish pass -- ^ tick we want to collect arguments past + -> Bool +canCollectArgsThroughTick id t + = tickishFloatable t + || (cantEtaReduceFun id && isProfTick t) -- | Can we eta-reduce the given function? -- See Note [Eta reduction soundness], criteria (B), (J), and (W). ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1052,8 +1052,8 @@ cpeApp top_env expr -- floating the tick which isn't optimal for perf. But this only makes -- a difference if we have a non-floatable tick which is somewhat rare. | Var vh <- head - , Var head' <- lookupCorePrepEnv top_env vh - , etaExpansionTick head' tickish + , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh) + , canCollectArgsThroughTick head' tickish = (head,as') where (head,as') = go fun (AITick tickish : as) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Types.Basic ( ConTag, ConTagZ, fIRST_TAG, Arity, VisArity, RepArity, JoinArity, FullArgCount, - JoinPointHood(..), isJoinPoint, + JoinPointType(..), JoinPointHood(..), joinPointHoodArity, isJoinPoint, Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -70,7 +70,7 @@ module GHC.Types.Basic ( BranchCount, oneBranch, InterestingCxt(..), TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, occInfoIsTrueJoinPoint, + isAlwaysTailCalled, occInfoJoinPointType_maybe, EP(..), @@ -1150,11 +1150,16 @@ instance Monoid InsideLam where ----------------- +joinPointHoodArity :: JoinPointHood -> Maybe JoinArity +joinPointHoodArity = \case + NotJoinPoint -> Nothing + JoinPoint { joinPointArity = ja } -> Just ja + -- | See Note [TailCallInfo] data TailCallInfo = AlwaysTailCalled - { tailCallArity :: {-# UNPACK #-} !JoinArity - , trueTailCall :: !Bool -- ^ is this a true join point? see Note [Quasi join points] + { tailCallArity :: {-# UNPACK #-} !JoinArity + , tailCallJoinPointType :: !JoinPointType -- ^ See Note [Quasi join points] } | NoTailCallInfo deriving (Eq) @@ -1176,14 +1181,14 @@ isAlwaysTailCalled occ -- If so, is it a true join point or a quasi join point? -- -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. -occInfoIsTrueJoinPoint :: OccInfo -> Maybe Bool -occInfoIsTrueJoinPoint occ = +occInfoJoinPointType_maybe :: OccInfo -> Maybe JoinPointType +occInfoJoinPointType_maybe occ = case tailCallInfo occ of - AlwaysTailCalled { trueTailCall = true } -> Just true + AlwaysTailCalled { tailCallJoinPointType = join_ty } -> Just join_ty NoTailCallInfo -> Nothing instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar t) = - sep [ text "Tail", (if t then empty else text "Quasi"), int ar ] + ppr (AlwaysTailCalled { tailCallJoinPointType = join_ty, tailCallArity = ar }) = + sep [ ppr join_ty <> text "Tail", int ar ] ppr NoTailCallInfo = text "NoTailCallInfo" ----------------- @@ -1232,8 +1237,11 @@ instance Outputable OccInfo where pp_tail = pprShortTailCallInfo tail_info pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar t) - = char 'T' <> (if t then empty else text "[Q]") +pprShortTailCallInfo + (AlwaysTailCalled + { tailCallJoinPointType = join_type + , tailCallArity = ar }) + = char 'T' <> (case join_type of { TrueJoinPoint -> empty; QuasiJoinPoint -> char 'Q' }) <> brackets (int ar) pprShortTailCallInfo NoTailCallInfo = empty ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -574,7 +574,7 @@ isWorkerLikeId id = isJoinId :: Var -> Bool isJoinId = isJust . joinId_maybe -joinId_maybe :: Var -> Maybe JoinType +joinId_maybe :: Var -> Maybe JoinPointType -- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId -- to the free vars of an expression, so it's convenient -- if it returns False for type variables @@ -589,10 +589,11 @@ idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id | isId id = case Var.idDetails id of - JoinId ty arity _marks -> - let isTrue = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False} - in JoinPoint isTrue arity - _ -> NotJoinPoint + JoinId + { joinIdType = join_type + , joinIdArity = arity } + -> JoinPoint join_type arity + _ -> NotJoinPoint | otherwise = NotJoinPoint idDataCon :: Id -> DataCon @@ -675,7 +676,7 @@ idJoinArity id = JoinPoint { joinPointArity = ar } -> ar NotJoinPoint -> pprPanic "idJoinArity" (ppr id) -asJoinId :: Id -> JoinType -> JoinArity -> JoinId +asJoinId :: Id -> JoinPointType -> JoinArity -> JoinId asJoinId id ty arity = warnPprTrace (not (isLocalId id)) "global id being marked as join var" (ppr id) $ @@ -710,9 +711,8 @@ zapJoinId jid asJoinId_maybe :: Id -> JoinPointHood -> Id asJoinId_maybe id = \case NotJoinPoint -> zapJoinId id - JoinPoint { isTrueJoinPoint = true_join, joinPointArity = arity } -> - let ty = if true_join then TrueJoinPoint else QuasiJoinPoint - in asJoinId id ty arity + JoinPoint { joinPointType = join_type, joinPointArity = arity } -> + asJoinId id join_type arity {- ************************************************************************ ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -65,7 +65,7 @@ module GHC.Types.Id.Info ( TailCallInfo(..), tailCallInfo, isAlwaysTailCalled, - JoinType(..), + JoinPointType(..), -- ** The RuleInfo type RuleInfo(..), @@ -207,7 +207,7 @@ data IdDetails -- This only covers /un-lifted/ coercions, of type -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants | JoinId - { joinIdType :: JoinType + { joinIdType :: JoinPointType , joinIdArity :: JoinArity , joinIdCbvMarks :: Maybe [CbvMark] } @@ -226,14 +226,6 @@ data IdDetails -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current -- module. -data JoinType - = TrueJoinPoint - | QuasiJoinPoint - deriving stock ( Eq, Show ) -instance Outputable JoinType where - ppr TrueJoinPoint = text "TrueJoinPoint" - ppr QuasiJoinPoint = text "QuasiJoinPoint" - data RecSelInfo = RSI { rsi_def :: [ConLike] -- Record selector defined for these , rsi_undef :: [ConLike] -- Record selector not defined for these @@ -422,7 +414,7 @@ isCoVarDetails :: IdDetails -> Bool isCoVarDetails CoVarId = True isCoVarDetails _ = False -isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinType, JoinArity, Maybe [CbvMark]) +isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinPointType, JoinArity, Maybe [CbvMark]) isJoinIdDetails_maybe (JoinId ty join_arity marks) = Just (ty, join_arity, marks) isJoinIdDetails_maybe _ = Nothing ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -330,7 +330,8 @@ tickishCanSplit _ = False -- | Is @join f x in <tick> jump f x@ valid? tickishCanScopeJoin :: GenTickish pass -> Bool tickishCanScopeJoin tick = case tick of - ProfNote{} -> True + ProfNote{} -> False -- Turns the join point into a quasi join point. + -- See Note [Quasi join points] HpcTick{} -> False Breakpoint{} -> False SourceNote{} -> True ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -132,7 +132,7 @@ import GHC.Utils.Fingerprint import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict -import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHC.Utils.Outputable( JoinPointHood(..), JoinPointType (..) ) import GHCi.FFI import GHCi.Message @@ -1053,6 +1053,10 @@ instance Binary DiffTime where get bh = do r <- get bh return $ fromRational r +instance Binary JoinPointType where + put_ bh ty = put_ bh (ty == TrueJoinPoint) + get bh = do { true <- get bh; return $ if true then TrueJoinPoint else QuasiJoinPoint } + instance Binary JoinPointHood where put_ bh NotJoinPoint = putByte bh 0 put_ bh (JoinPoint t ar) = do ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -15,7 +15,7 @@ module GHC.Utils.Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), - BindingSite(..), JoinPointHood(..), isJoinPoint, + BindingSite(..), JoinPointType(..), JoinPointHood(..), isJoinPoint, IsOutput(..), IsLine(..), IsDoc(..), HLine, HDoc, @@ -150,6 +150,7 @@ import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup (Arg(..)) +import qualified Data.Semigroup as Semi import qualified Data.List.NonEmpty as NEL import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 @@ -1284,10 +1285,21 @@ data BindingSite | LetBind -- ^ The x in (let x = rhs in e) deriving Eq +data JoinPointType + = TrueJoinPoint + | QuasiJoinPoint + deriving Eq +instance Outputable JoinPointType where + ppr TrueJoinPoint = empty + ppr QuasiJoinPoint = text "Quasi" +instance Semigroup JoinPointType where + TrueJoinPoint <> TrueJoinPoint = TrueJoinPoint + _ <> _ = QuasiJoinPoint + data JoinPointHood = JoinPoint - { isTrueJoinPoint :: {-# UNPACK #-} !Bool - , joinPointArity :: {-# UNPACK #-} !Int + { joinPointType :: {-# UNPACK #-} !JoinPointType + , joinPointArity :: {-# UNPACK #-} !Int -- ^ The JoinArity (but an Int here because synonym JoinArity is defined in Types.Basic) } | NotJoinPoint @@ -1298,10 +1310,9 @@ isJoinPoint (JoinPoint {}) = True isJoinPoint NotJoinPoint = False instance Outputable JoinPointHood where - ppr NotJoinPoint = text "NotJoinPoint" - ppr (JoinPoint true arity) = - (if true then empty else text "Quasi") - <> text "JoinPoint" <> parens (ppr arity) + ppr NotJoinPoint = text "NotJoinPoint" + ppr (JoinPoint join_type arity) = + ppr join_type <> text "JoinPoint" <> parens (ppr arity) instance NFData JoinPointHood where rnf x = x `seq` () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d01b5ee6554022b6898aed101f3cf7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d01b5ee6554022b6898aed101f3cf7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: PPC NCG: Generate clear right insn at arch width
by Marge Bot (＠marge-bot) 26 Jan '26

26 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 56db94f7 by Peter Trommler at 2026-01-26T11:26:18+01:00 PPC NCG: Generate clear right insn at arch width The clear right immediate (clrrxi) is only available in word and doubleword width. Generate clrrxi instructions at architecture width for all MachOp widths. Fixes #24145 - - - - - 8be9bd2c by Greg Steuck at 2026-01-26T14:07:25-05:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - a56b0585 by Matthew Pickering at 2026-01-26T14:07:25-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 13 changed files: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - libraries/base/changelog.md - libraries/base/tests/perf/Makefile - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout Changes: ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -539,7 +539,7 @@ getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps CLRLI arch_fmt dst src1 (arch_bits - size) return (Any (intFormat to) code) -getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps +getRegister' _ platform (CmmMachOp mop [x, y]) -- dyadic PrimOps = case mop of MO_F_Eq _ -> condFltReg EQQ x y MO_F_Ne _ -> condFltReg NE x y @@ -622,8 +622,9 @@ getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps (src, srcCode) <- getSomeReg x let clear_mask = if imm == -4 then 2 else 3 fmt = intFormat rep + arch_fmt = intFormat (wordWidth platform) code dst = srcCode - `appOL` unitOL (CLRRI fmt dst src clear_mask) + `appOL` unitOL (CLRRI arch_fmt dst src clear_mask) return (Any fmt code) _ -> trivialCode rep False AND x y MO_Or rep -> trivialCode rep False OR x y ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/561c3821f59fa243c38b644d8eb2b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/561c3821f59fa243c38b644d8eb2b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/stability-risk-1-and-2-module-deprecation] Enable `CPP` in the modules to be deprecated
by Wolfgang Jeltsch (＠jeltsch) 26 Jan '26

26 Jan '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/stability-risk-1-and-2-module-deprecation at Glasgow Haskell Compiler / GHC Commits: 0713a2e4 by Wolfgang Jeltsch at 2026-01-26T18:10:21+02:00 Enable `CPP` in the modules to be deprecated - - - - - 15 changed files: - libraries/base/src/GHC/Arr.hs - libraries/base/src/GHC/ArrayArray.hs - libraries/base/src/GHC/Conc/IO.hs - libraries/base/src/GHC/Encoding/UTF8.hs - libraries/base/src/GHC/Exception.hs - libraries/base/src/GHC/Exception/Type.hs - libraries/base/src/GHC/Fingerprint/Type.hs - libraries/base/src/GHC/IO/Buffer.hs - libraries/base/src/GHC/IO/Device.hs - libraries/base/src/GHC/IO/Encoding.hs - libraries/base/src/GHC/IO/Exception.hs - libraries/base/src/GHC/IO/Handle/Text.hs - libraries/base/src/GHC/InfoProv.hs - libraries/base/src/GHC/Stack/Types.hs - libraries/base/src/GHC/TopHandler.hs Changes: ===================================== libraries/base/src/GHC/Arr.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} -- | ===================================== libraries/base/src/GHC/ArrayArray.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# LANGUAGE MagicHash #-} ===================================== libraries/base/src/GHC/Conc/IO.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} -- | ===================================== libraries/base/src/GHC/Encoding/UTF8.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -- | ===================================== libraries/base/src/GHC/Exception.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/base/src/GHC/Exception/Type.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/base/src/GHC/Fingerprint/Type.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ===================================== libraries/base/src/GHC/IO/Buffer.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ===================================== libraries/base/src/GHC/IO/Device.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ===================================== libraries/base/src/GHC/IO/Encoding.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ===================================== libraries/base/src/GHC/IO/Exception.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/base/src/GHC/IO/Handle/Text.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/base/src/GHC/InfoProv.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ===================================== libraries/base/src/GHC/Stack/Types.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/base/src/GHC/TopHandler.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0713a2e4a1c19e8f40e0d7bc5d983df… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0713a2e4a1c19e8f40e0d7bc5d983df… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] 4 commits: ci: remove duplicate keys in .gitlab-ci.yml
by Wolfgang Jeltsch (＠jeltsch) 26 Jan '26

26 Jan '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: 414b9593 by Cheng Shao at 2026-01-24T07:11:51-05:00 ci: remove duplicate keys in .gitlab-ci.yml This patch removes accidentally duplicate keys in `.gitlab-ci.yml`. The YAML spec doesn't allow duplicate keys in the first place, and according to GitLab docs (https://docs.gitlab.com/ci/yaml/yaml_optimization/#anchors) the latest key overrides the earlier entries. - - - - - e5cb5491 by Cheng Shao at 2026-01-24T07:12:34-05:00 hadrian: drop obsolete configure/make builder logic for libffi This patch drops obsolete hadrian logic around `Configure libffiPath`/`Make libffiPath` builders, they are no longer needed after libffi-clib has landed. Closes #26815. - - - - - 2d160222 by Simon Hengel at 2026-01-24T07:13:17-05:00 Fix typo in roles.rst - - - - - e48d5ad1 by Wolfgang Jeltsch at 2026-01-26T17:39:38+02:00 Add operations for obtaining operating-system handles This contribution implements CLC proposal #369. It adds operations for obtaining POSIX file descriptors and Windows handles that underlie Haskell handles. Those operating system handles can also be obtained without such additional operations, but this is more involved and, more importantly, requires using internals. - - - - - 27 changed files: - .gitlab-ci.yml - docs/users_guide/exts/roles.rst - hadrian/src/Context.hs - hadrian/src/Settings/Builders/Configure.hs - hadrian/src/Settings/Builders/Make.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/System/IO/OS.hs - libraries/base/tests/IO/all.T - + libraries/base/tests/IO/osHandles001FileDescriptors.hs - + libraries/base/tests/IO/osHandles001FileDescriptors.stdout - + libraries/base/tests/IO/osHandles001WindowsHandles.hs - + libraries/base/tests/IO/osHandles001WindowsHandles.stdout - + libraries/base/tests/IO/osHandles002FileDescriptors.hs - + libraries/base/tests/IO/osHandles002FileDescriptors.stderr - + libraries/base/tests/IO/osHandles002FileDescriptors.stdin - + libraries/base/tests/IO/osHandles002FileDescriptors.stdout - + libraries/base/tests/IO/osHandles002WindowsHandles.hs - + libraries/base/tests/IO/osHandles002WindowsHandles.stderr - + libraries/base/tests/IO/osHandles002WindowsHandles.stdin - + libraries/base/tests/IO/osHandles002WindowsHandles.stdout - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1050,10 +1050,6 @@ abi-test: optional: true dependencies: null image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" - rules: - - if: $CI_MERGE_REQUEST_ID - - if: '$CI_COMMIT_BRANCH == "master"' - - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/' tags: - x86_64-linux script: ===================================== docs/users_guide/exts/roles.rst ===================================== @@ -38,7 +38,7 @@ trouble. The way to identify such situations is to have *roles* assigned to type variables of datatypes, classes, and type synonyms. -Roles as implemented in GHC are a from a simplified version of the work +Roles as implemented in GHC are based on a simplified version of the work described in `Generative type abstraction and type-level computation <https://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf>`__, published at POPL 2011. ===================================== hadrian/src/Context.hs ===================================== @@ -11,7 +11,7 @@ module Context ( pkgLibraryFile, pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir, distDynDir, - haddockStatsFilesDir, ensureConfigured, autogenPath, rtsContext, rtsBuildPath, libffiBuildPath + haddockStatsFilesDir, ensureConfigured, autogenPath, rtsContext, rtsBuildPath ) where import Base @@ -93,14 +93,6 @@ rtsContext stage = vanillaContext stage rts rtsBuildPath :: Stage -> Action FilePath rtsBuildPath stage = buildPath (rtsContext stage) --- | Build directory for in-tree 'libffi' library. -libffiBuildPath :: Stage -> Action FilePath -libffiBuildPath stage = buildPath $ Context - stage - libffi - (error "libffiBuildPath: way not set.") - (error "libffiBuildPath: inplace not set.") - pkgFileName :: Context -> Package -> String -> String -> Action FilePath pkgFileName context package prefix suffix = do pid <- pkgUnitId (stage context) package ===================================== hadrian/src/Settings/Builders/Configure.hs ===================================== @@ -8,8 +8,7 @@ configureBuilderArgs :: Args configureBuilderArgs = do stage <- getStage gmpPath <- expr (gmpBuildPath stage) - libffiPath <- expr (libffiBuildPath stage) - mconcat [ builder (Configure gmpPath) ? do + builder (Configure gmpPath) ? do targetArch <- queryTarget queryArch targetPlatform <- queryTarget targetPlatformTriple buildPlatform <- queryBuild targetPlatformTriple @@ -28,16 +27,3 @@ configureBuilderArgs = do -- option. <> [ "--enable-alloca=malloc-notreentrant" | targetArch == "wasm32" ] <> [ "--with-pic=yes" ] - - , builder (Configure libffiPath) ? do - top <- expr topDirectory - targetPlatform <- queryTarget targetPlatformTriple - way <- getWay - pure [ "--prefix=" ++ top -/- libffiPath -/- "inst" - , "--libdir=" ++ top -/- libffiPath -/- "inst/lib" - , "--enable-static=yes" - , "--enable-shared=" - ++ (if wayUnit Dynamic way - then "yes" - else "no") - , "--host=" ++ targetPlatform ] ] ===================================== hadrian/src/Settings/Builders/Make.hs ===================================== @@ -12,12 +12,8 @@ makeBuilderArgs = do threads <- shakeThreads <$> expr getShakeOptions stage <- getStage gmpPath <- expr (gmpBuildPath stage) - libffiPaths <- forM [Stage1, Stage2, Stage3 ] $ \s -> expr (libffiBuildPath s) let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads - mconcat $ - (builder (Make gmpPath ) ? pure ["MAKEFLAGS=-j" ++ t]) : - [ builder (Make libffiPath) ? pure ["MAKEFLAGS=-j" ++ t, "install"] - | libffiPath <- libffiPaths ] + builder (Make gmpPath) ? pure ["MAKEFLAGS=-j" ++ t] validateBuilderArgs :: Args validateBuilderArgs = builder (Make "testsuite/tests") ? do ===================================== libraries/base/base.cabal.in ===================================== @@ -255,6 +255,7 @@ Library , System.Exit , System.IO , System.IO.Error + , System.IO.OS , System.Mem , System.Mem.StableName , System.Posix.Internals ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -0,0 +1,62 @@ +{-# LANGUAGE Safe #-} + +{-| + This module bridges between Haskell handles and underlying operating-system + features. +-} +module System.IO.OS +( + -- * Obtaining file descriptors and Windows handles + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + + -- ** Caveats + -- $with-ref-caveats +) +where + +import GHC.Internal.System.IO.OS + ( + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +-- ** Caveats + +{-$with-ref-caveats + #with-ref-caveats#There are the following caveats regarding the above + operations: + + * Flushing of buffers can fail if the given handle is readable but not + seekable. + + * If one of these operations is performed as part of an action executed by + 'System.IO.Unsafe.unsafePerformIO', + 'System.IO.Unsafe.unsafeInterleaveIO', or one of their “dupable” + variants and the user-provided action receives an asychnchronous + exception and does not catch it, then the following happens: + + - Before the overall computation is suspended, the blocking of handle + operations is removed. + + - When the computation is later resumed due to another evaluation + attempt, the blocking of handle operations is reinstantiated, the + Haskell-managed buffers are flushed again, and the user-provided + action is run from the beginning. + + Repeating the previously executed part of the user-provided action + cannot be avoided apparently. See the @[async]@ note in the source code + of "GHC.Internal.IO.Handle.Internals" for further explanation. +-} ===================================== libraries/base/tests/IO/all.T ===================================== @@ -186,3 +186,15 @@ test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(1) test('T18832', only_ways(['threaded1']), compile_and_run, ['']) test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compile_and_run, ['']) + +test('osHandles001FileDescriptors', omit_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +test('osHandles001WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +test('osHandles002FileDescriptors', [when(opsys('mingw32'), skip), when(arch('javascript'), skip)], compile_and_run, ['']) +test('osHandles002WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +# It would be good to let `osHandles002FileDescriptors` run also on +# Windows with the file-descriptor-based I/O manager. However, this +# test, as it is currently implemented, requires the `unix` package. +# That said, `UCRT.DLL`, which is used by GHC-generated Windows +# executables, emulates part of POSIX, enough for this test. As a +# result, this test could be generalized to also supporting Windows, but +# this would likely involve creating bindings to C code. ===================================== libraries/base/tests/IO/osHandles001FileDescriptors.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (mapM_) +import Control.Exception (SomeException, try) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +main :: IO () +main = mapM_ ((>>= print) . try @SomeException) $ + [ + withFileDescriptorReadingBiasedRaw stdin (return . show), + withFileDescriptorWritingBiasedRaw stdout (return . show), + withFileDescriptorWritingBiasedRaw stderr (return . show), + withWindowsHandleReadingBiasedRaw stdin (return . const "_"), + withWindowsHandleWritingBiasedRaw stdout (return . const "_"), + withWindowsHandleWritingBiasedRaw stderr (return . const "_") + ] ===================================== libraries/base/tests/IO/osHandles001FileDescriptors.stdout ===================================== @@ -0,0 +1,6 @@ +Right "0" +Right "1" +Right "2" +Left <stdin>: withWindowsHandleReadingBiasedRaw: inappropriate type (handle does not use Windows handles) +Left <stdout>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles) +Left <stderr>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles) ===================================== libraries/base/tests/IO/osHandles001WindowsHandles.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (mapM_) +import Control.Exception (SomeException, try) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +main :: IO () +main = mapM_ ((>>= print) . try @SomeException) $ + [ + withFileDescriptorReadingBiasedRaw stdin (return . show), + withFileDescriptorWritingBiasedRaw stdout (return . show), + withFileDescriptorWritingBiasedRaw stderr (return . show), + withWindowsHandleReadingBiasedRaw stdin (return . const "_"), + withWindowsHandleWritingBiasedRaw stdout (return . const "_"), + withWindowsHandleWritingBiasedRaw stderr (return . const "_") + ] ===================================== libraries/base/tests/IO/osHandles001WindowsHandles.stdout ===================================== @@ -0,0 +1,6 @@ +Left <stdin>: withFileDescriptorReadingBiasedRaw: inappropriate type (handle does not use file descriptors) +Left <stdout>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors) +Left <stderr>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors) +Right "_" +Right "_" +Right "_" ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.hs ===================================== @@ -0,0 +1,28 @@ +import Data.Functor (void) +import Data.ByteString.Char8 (pack) +import System.Posix.Types (Fd (Fd), ByteCount) +import System.Posix.IO.ByteString (fdRead, fdWrite) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased + ) + +main :: IO () +main = withFileDescriptorReadingBiased stdin $ \ stdinFD -> + withFileDescriptorWritingBiased stdout $ \ stdoutFD -> + withFileDescriptorWritingBiased stderr $ \ stderrFD -> + do + regularMsg <- fdRead (Fd stdinFD) inputSizeApproximation + void $ fdWrite (Fd stdoutFD) regularMsg + void $ fdWrite (Fd stderrFD) (pack errorMsg) + where + + inputSizeApproximation :: ByteCount + inputSizeApproximation = 100 + + errorMsg :: String + errorMsg = "And every single door\n\ + \That I've walked through\n\ + \Brings me back, back here again\n" ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stderr ===================================== @@ -0,0 +1,3 @@ +And every single door +That I've walked through +Brings me back, back here again ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stdin ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stdout ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.hs ===================================== @@ -0,0 +1,49 @@ +import Control.Monad (zipWithM_) +import Data.Functor (void) +import Data.Char (ord) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Storable (pokeElemOff) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased + ) + +main :: IO () +main = withWindowsHandleReadingBiased stdin $ \ windowsStdin -> + withWindowsHandleWritingBiased stdout $ \ windowsStdout -> + withWindowsHandleWritingBiased stderr $ \ windowsStderr -> + do + withBuffer inputSizeApproximation $ \ bufferPtr -> do + inputSize <- win32_ReadFile windowsStdin + bufferPtr + inputSizeApproximation + Nothing + void $ win32_WriteFile windowsStdout + bufferPtr + inputSize + Nothing + withBuffer errorMsgSize $ \ bufferPtr -> do + zipWithM_ (pokeElemOff bufferPtr) + [0 ..] + (map (fromIntegral . ord) errorMsg) + void $ win32_WriteFile windowsStderr + bufferPtr + errorMsgSize + Nothing + where + + withBuffer :: DWORD -> (Ptr Word8 -> IO a) -> IO a + withBuffer = allocaBytes . fromIntegral + + inputSizeApproximation :: DWORD + inputSizeApproximation = 100 + + errorMsg :: String + errorMsg = "And every single door\n\ + \That I've walked through\n\ + \Brings me back, back here again\n" + + errorMsgSize :: DWORD + errorMsgSize = fromIntegral (length errorMsg) ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stderr ===================================== @@ -0,0 +1,3 @@ +And every single door +That I've walked through +Brings me back, back here again ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stdin ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stdout ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -328,6 +328,7 @@ Library GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error + GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs ===================================== @@ -0,0 +1,323 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +{-| + This module bridges between Haskell handles and underlying operating-system + features. +-} +module GHC.Internal.System.IO.OS +( + -- * Obtaining file descriptors and Windows handles + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + + -- ** Caveats + -- $with-ref-caveats +) +where + +import GHC.Internal.Control.Monad (return) +import GHC.Internal.Control.Concurrent.MVar (MVar) +import GHC.Internal.Control.Exception (mask) +import GHC.Internal.Data.Function (const, (.), ($)) +import GHC.Internal.Data.Functor (fmap) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Bool (otherwise) +#endif +import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Maybe (Maybe (Just)) +#endif +import GHC.Internal.Data.List ((++)) +import GHC.Internal.Data.String (String) +import GHC.Internal.Data.Typeable (Typeable, cast) +import GHC.Internal.System.IO (IO) +import GHC.Internal.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.Internal.IO.Windows.Handle + ( + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE + ) +#endif +import GHC.Internal.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.Internal.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import GHC.Internal.Foreign.Ptr (Ptr) +import GHC.Internal.Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) + +-- ** Caveats + +{-$with-ref-caveats + #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve + as the target of the hyperlinks above. The real documentation of the caveats + is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which + re-exports the above operations. +-} ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10048,6 +10048,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -10086,6 +10086,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -10328,6 +10328,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -10048,6 +10048,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4bad11d6f13323819efb62093090b7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4bad11d6f13323819efb62093090b7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] Disable `osHandles002FileDescriptors` for JavaScript
by Wolfgang Jeltsch (＠jeltsch) 26 Jan '26

26 Jan '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: 4bad11d6 by Wolfgang Jeltsch at 2026-01-26T17:31:52+02:00 Disable `osHandles002FileDescriptors` for JavaScript - - - - - 1 changed file: - libraries/base/tests/IO/all.T Changes: ===================================== libraries/base/tests/IO/all.T ===================================== @@ -189,7 +189,7 @@ test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compi test('osHandles001FileDescriptors', omit_ways(['winio', 'winio_threaded']), compile_and_run, ['']) test('osHandles001WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) -test('osHandles002FileDescriptors', when(opsys('mingw32'), skip), compile_and_run, ['']) +test('osHandles002FileDescriptors', [when(opsys('mingw32'), skip), when(arch('javascript'), skip)], compile_and_run, ['']) test('osHandles002WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) # It would be good to let `osHandles002FileDescriptors` run also on # Windows with the file-descriptor-based I/O manager. However, this View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bad11d6f13323819efb62093090b70… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bad11d6f13323819efb62093090b70… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26830
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

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

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Move flags to precede patterns for grep and read files directly
by Marge Bot (＠marge-bot) 26 Jan '26

26 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f5d77d20 by Greg Steuck at 2026-01-25T00:01:43+00:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - 561c3821 by Matthew Pickering at 2026-01-26T08:52:01-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 12 changed files: - libraries/base/changelog.md - libraries/base/tests/perf/Makefile - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout Changes: ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3e64e1e76a6099e96d7ed1dabab5e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3e64e1e76a6099e96d7ed1dabab5e… You're receiving this email because of your account on gitlab.haskell.org.

1 0