- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T26961] 2 commits: Add Data.RealFloat
by Brandon Chinn (＠brandonchinn178) 27 Feb '26

27 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: 3ccd11ee by Brandon Chinn at 2026-02-26T18:09:54-08:00 Add Data.RealFloat - - - - - d77fec68 by Brandon Chinn at 2026-02-26T18:09:54-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 4 changed files: - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs - testsuite/tests/interface-stability/base-exports.stdout Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -111,6 +111,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries(a)haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import GHC.Internal.Data.Bool +import GHC.Internal.Data.Ord +import GHC.Internal.Float +import GHC.Internal.Real + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1597,6 +1597,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational @@ -11952,6 +11975,8 @@ instance forall k (f :: k -> *) (a :: k). GHC.Internal.Enum.Enum (f a) => GHC.In instance forall k (f :: k -> *) (a :: k). GHC.Internal.Enum.Enum (f a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Monoid.Ap f a) -- Defined in ‘GHC.Internal.Data.Monoid’ instance forall a. (GHC.Internal.Enum.Enum a, GHC.Internal.Enum.Bounded a, GHC.Internal.Classes.Eq a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Enum.Enum (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ +instance GHC.Internal.Enum.Enum GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Enum.Enum GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance forall a. GHC.Internal.Enum.Enum a => GHC.Internal.Enum.Enum (Data.Semigroup.First a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Enum.Enum a => GHC.Internal.Enum.Enum (Data.Semigroup.Last a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Enum.Enum a => GHC.Internal.Enum.Enum (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ @@ -11991,8 +12016,6 @@ instance GHC.Internal.Enum.Enum GHC.Internal.Foreign.C.Types.CUSeconds -- Define instance GHC.Internal.Enum.Enum GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Enum.Enum GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Enum.Enum GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.Internal.ByteOrder’ -instance GHC.Internal.Enum.Enum GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ -instance GHC.Internal.Enum.Enum GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Enum.Enum GHC.Internal.Generics.Associativity -- Defined in ‘GHC.Internal.Generics’ instance GHC.Internal.Enum.Enum GHC.Internal.Generics.DecidedStrictness -- Defined in ‘GHC.Internal.Generics’ instance GHC.Internal.Enum.Enum GHC.Internal.Generics.SourceStrictness -- Defined in ‘GHC.Internal.Generics’ @@ -12039,18 +12062,18 @@ instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Flo instance forall a b. GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (Data.Functor.Contravariant.Op a b) -- Defined in ‘Data.Functor.Contravariant’ instance forall a. GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance forall a. GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ -instance GHC.Internal.Float.Floating GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Float.Floating GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Float.Floating GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Float.Floating GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Float.Floating GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance GHC.Internal.Float.Floating GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance forall a k (b :: k). GHC.Internal.Float.RealFloat a => GHC.Internal.Float.RealFloat (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.RealFloat (f (g a)) => GHC.Internal.Float.RealFloat (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.RealFloat (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.RealFloat (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ -instance GHC.Internal.Float.RealFloat GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Float.RealFloat GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Float.RealFloat GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Float.RealFloat GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Float.RealFloat GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance GHC.Internal.Float.RealFloat GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance forall a k (b :: k). GHC.Internal.Foreign.Storable.Storable a => GHC.Internal.Foreign.Storable.Storable (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Foreign.Storable.Storable a => GHC.Internal.Foreign.Storable.Storable (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ instance forall a. GHC.Internal.Foreign.Storable.Storable a => GHC.Internal.Foreign.Storable.Storable (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ @@ -12379,6 +12402,8 @@ instance forall a. GHC.Internal.Num.Num a => GHC.Internal.Num.Num (GHC.Internal. instance forall (f :: * -> *) a. (GHC.Internal.Base.Applicative f, GHC.Internal.Num.Num a) => GHC.Internal.Num.Num (GHC.Internal.Data.Monoid.Ap f a) -- Defined in ‘GHC.Internal.Data.Monoid’ instance forall a. GHC.Internal.Num.Num a => GHC.Internal.Num.Num (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Num.Num (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ +instance GHC.Internal.Num.Num GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Num.Num GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance forall a. GHC.Internal.Num.Num a => GHC.Internal.Num.Num (Data.Semigroup.Max a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Num.Num a => GHC.Internal.Num.Num (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Num.Num GHC.Internal.Word.Word16 -- Defined in ‘GHC.Internal.Word’ @@ -12413,8 +12438,6 @@ instance GHC.Internal.Num.Num GHC.Internal.Foreign.C.Types.CULong -- Defined in instance GHC.Internal.Num.Num GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Num.Num GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Num.Num GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Num.Num GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ -instance GHC.Internal.Num.Num GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Num.Num GHC.Internal.Types.Int -- Defined in ‘GHC.Internal.Num’ instance GHC.Internal.Num.Num GHC.Internal.Bignum.Integer.Integer -- Defined in ‘GHC.Internal.Num’ instance GHC.Internal.Num.Num GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Num’ @@ -12556,10 +12579,10 @@ instance forall a b. GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractio instance forall a. GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance forall a. GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Real.Fractional (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ -instance GHC.Internal.Real.Fractional GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Real.Fractional GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Real.Fractional GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Real.Fractional GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Real.Fractional GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance GHC.Internal.Real.Fractional GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance forall a k (b :: k). GHC.Internal.Real.Integral a => GHC.Internal.Real.Integral (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Real.Integral (f (g a)) => GHC.Internal.Real.Integral (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Real.Integral (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ @@ -12611,6 +12634,8 @@ instance GHC.Internal.Real.Real GHC.Internal.Bignum.Integer.Integer -- Defined i instance GHC.Internal.Real.Real GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Real’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Real.Real (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ instance GHC.Internal.Real.Real GHC.Internal.Types.Word -- Defined in ‘GHC.Internal.Real’ +instance GHC.Internal.Real.Real GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Real.Real GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Real.Real GHC.Internal.Word.Word16 -- Defined in ‘GHC.Internal.Word’ instance GHC.Internal.Real.Real GHC.Internal.Word.Word32 -- Defined in ‘GHC.Internal.Word’ instance GHC.Internal.Real.Real GHC.Internal.Word.Word64 -- Defined in ‘GHC.Internal.Word’ @@ -12643,18 +12668,16 @@ instance GHC.Internal.Real.Real GHC.Internal.Foreign.C.Types.CULong -- Defined i instance GHC.Internal.Real.Real GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Real.Real GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Real.Real GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Real.Real GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ -instance GHC.Internal.Real.Real GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance forall a k (b :: k). GHC.Internal.Real.RealFrac a => GHC.Internal.Real.RealFrac (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall k (a :: k). Data.Fixed.HasResolution a => GHC.Internal.Real.RealFrac (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Real.RealFrac (f (g a)) => GHC.Internal.Real.RealFrac (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’ instance forall a. GHC.Internal.Real.RealFrac a => GHC.Internal.Real.RealFrac (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance forall a. GHC.Internal.Real.RealFrac a => GHC.Internal.Real.RealFrac (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. GHC.Internal.Real.Integral a => GHC.Internal.Real.RealFrac (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ -instance GHC.Internal.Real.RealFrac GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ -instance GHC.Internal.Real.RealFrac GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Real.RealFrac GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ instance GHC.Internal.Real.RealFrac GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Real.RealFrac GHC.Internal.Foreign.C.Types.CDouble -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance GHC.Internal.Real.RealFrac GHC.Internal.Foreign.C.Types.CFloat -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance forall k a (b :: k). GHC.Internal.Show.Show a => GHC.Internal.Show.Show (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (GHC.Internal.Functor.ZipList.ZipList a) -- Defined in ‘GHC.Internal.Functor.ZipList’ instance GHC.Internal.Show.Show GHC.Internal.Conc.Sync.BlockReason -- Defined in ‘GHC.Internal.Conc.Sync’ @@ -12768,6 +12791,8 @@ instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (GHC.Inter instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance GHC.Internal.Show.Show GHC.Internal.Real.FractionalExponentBase -- Defined in ‘GHC.Internal.Real’ instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (GHC.Internal.Real.Ratio a) -- Defined in ‘GHC.Internal.Real’ +instance GHC.Internal.Show.Show GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ +instance GHC.Internal.Show.Show GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance forall a b. (GHC.Internal.Show.Show a, GHC.Internal.Show.Show b) => GHC.Internal.Show.Show (Data.Semigroup.Arg a b) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (Data.Semigroup.First a) -- Defined in ‘Data.Semigroup’ instance forall a. GHC.Internal.Show.Show a => GHC.Internal.Show.Show (Data.Semigroup.Last a) -- Defined in ‘Data.Semigroup’ @@ -12823,8 +12848,6 @@ instance GHC.Internal.Show.Show ghc-internal-9.1500.0:GHC.Internal.Event.Manager instance GHC.Internal.Show.Show ghc-internal-9.1500.0:GHC.Internal.Event.Manager.State -- Defined in ‘ghc-internal-9.1500.0:GHC.Internal.Event.Manager’ instance GHC.Internal.Show.Show ghc-internal-9.1500.0:GHC.Internal.Event.TimerManager.State -- Defined in ‘ghc-internal-9.1500.0:GHC.Internal.Event.TimerManager’ instance GHC.Internal.Show.Show GHC.Internal.Fingerprint.Type.Fingerprint -- Defined in ‘GHC.Internal.Fingerprint.Type’ -instance GHC.Internal.Show.Show GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Float’ -instance GHC.Internal.Show.Show GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Float’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Show.Show (f p), GHC.Internal.Show.Show (g p)) => GHC.Internal.Show.Show ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Show.Show (f p), GHC.Internal.Show.Show (g p)) => GHC.Internal.Show.Show ((GHC.Internal.Generics.:+:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1). GHC.Internal.Show.Show (f (g p)) => GHC.Internal.Show.Show ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fab8136ede6e3bb48e53aef94307ff… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fab8136ede6e3bb48e53aef94307ff… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/reduce-type-in-stg
by Jaro Reinders (＠jaro) 27 Feb '26

27 Feb '26

Jaro Reinders pushed new branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/reduce-type-in-stg You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] Improvements in ErrCtxt
by Simon Peyton Jones (＠simonpj) 27 Feb '26

27 Feb '26

Simon Peyton Jones pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 5cca9b8d by Simon Peyton Jones at 2026-02-27T00:44:47+00:00 Improvements in ErrCtxt - - - - - 24 changed files: - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs Changes: ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -21,6 +21,7 @@ import GHC.Driver.Session import GHC.Tc.Errors.Types import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..) ) import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.Deriv.Generate @@ -695,7 +696,7 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo = setSrcSpanA loc $ addErrCtxt (StandaloneDerivCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True + ; let ctxt = GHC.Tc.Types.ErrCtxt.InstDeclCtxt True ; traceTc "Deriving strategy (standalone deriving)" $ vcat [ppr mb_lderiv_strat, ppr deriv_ty] ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Tc.Deriv.Generics import GHC.Tc.Errors.Types import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt( InstDeclCtxt, DerivClauseCtxt ) ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Tc.Zonk.Type import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( redundantConstraintsSpan ) import GHC.Tc.Types.Evidence import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7703,11 +7703,17 @@ pprErrCtxtMsg = \case make_lines_msg [last] = ppr last <> dot make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls + PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] + , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] + where + -- Zonking will have turned Infer into Check + pp_res_ty = case res_ty of + Check ty -> ppr ty + Infer ir -> text "OOPS" <+> ppr ir + PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) PatSynDeclCtxt name -> ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -184,7 +184,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence (EvBindsVar) import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) - , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing + , TyVarBndrs, TypedThing , FixedRuntimeRepOrigin(..), InstanceWhat ) import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, SubGoalDepth ) import GHC.Tc.Types.Rank (Rank) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify import GHC.Tc.Solver ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -41,6 +41,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint( WantedConstraints ) import GHC.Tc.Utils.TcType as TcType ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -52,6 +52,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt( GenSigCtxt ), pprUserTypeCtxt ) import GHC.Tc.Types.Evidence import GHC.Rename.Env ( irrefutableConLikeTc ) ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Origin ( UserTypeCtxt ) +import GHC.Tc.Types.ErrCtxt ( UserTypeCtxt ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Types.Name ( Name ) import GHC.Hs.Extension ( GhcRn, GhcTc ) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1021,8 +1021,7 @@ tcPatSig in_pat_bind sig res_ty ; case NE.nonEmpty sig_tvs of Nothing -> do { -- Just do the subsumption check and return - msg <- mk_msg res_ty sig_ty - ; wrap <- addErrCtxtM msg $ + ; wrap <- addErrCtxtM (PatSigErrCtxt sig_ty res_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) } @@ -1036,17 +1035,12 @@ tcPatSig in_pat_bind sig res_ty (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) -- Now do a subsumption check of the pattern signature against res_ty - msg <- mk_msg res_ty sig_ty - wrap <- addErrCtxtM msg $ + wrap <- addErrCtxtM (PatSigErrCtxt sig_ty res_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty -- Phew! return (sig_ty, sig_tvs, sig_wcs, wrap) } - where - mk_msg res_ty sig_ty - = do { res_ty <- readExpType res_ty -- should be filled in by now - ; return $ PatSigErrCtxt sig_ty res_ty } {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -50,6 +50,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Instance.Family import GHC.Tc.Gen.Annotation ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin ) import GHC.Tc.Types import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..), reportRedundantConstraints ) import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc( mkGivenLoc ) import GHC.Tc.Solver.InertSet ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -58,6 +58,7 @@ import GHC.Tc.Instance.Family import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy ) ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..) ) import GHC.Tc.TyCl.Build import GHC.Core.Multiplicity ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Tc.Types.BasicTypes ( import GHC.Prelude -import GHC.Tc.Types.Origin( UserTypeCtxt ) +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt ) import GHC.Tc.Utils.TcType import GHC.Types.Id ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -120,6 +120,7 @@ import GHC.Types.Var import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.CtLoc import GHC.Builtin.Names ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -4,6 +4,11 @@ module GHC.Tc.Types.ErrCtxt ( ErrCtxt (..), ErrCtxtMsg(..), CodeSrcFlag (..) , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) + + -- * UserTypeCtxt + , UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe + , ReportRedundantConstraints(..), reportRedundantConstraints + , redundantConstraintsSpan, ) where @@ -16,12 +21,12 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( TcType, TcTyCon ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Tc.Utils.TcType ( TcType, TcTyCon, ExpType ) import GHC.Types.Basic ( TyConFlavour ) import GHC.Types.Name ( Name ) -import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.SrcLoc ( SrcSpan, noSrcSpan ) import GHC.Types.Var ( Id, TyCoVar ) import GHC.Unit.Types ( Module, InstantiatedModule ) @@ -35,7 +40,7 @@ import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType ) import {-# SOURCE #-} GHC.Unit.State ( UnitState ) -- Break the module graph cycle for accesing ErrCtxtMsg in GHC.Hs.Expr import GHC.Data.FastString ( FastString ) -import GHC.Utils.Outputable ( Outputable(..) ) +import GHC.Utils.Outputable import Language.Haskell.Syntax import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) @@ -43,6 +48,156 @@ import GHC.Boot.TH.Syntax qualified as TH import qualified Data.List.NonEmpty as NE +{- ********************************************************************* +* * + UserTypeCtxt +* * +********************************************************************* -} + +------------------------------------- +-- | UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need an expression to have that type +data UserTypeCtxt + = FunSigCtxt -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + Name -- Name of the function + ReportRedundantConstraints + -- See Note [Tracking needed EvIds] in GHC.Tc.Solver + -- This field is usually 'WantRCC', but 'NoRCC' for + -- * Record selectors (not important here) + -- * Class and instance methods. Here the code may legitimately + -- be more polymorphic than the signature generated from the + -- class declaration + -- * Functions whose type signature has hidden the constraints + -- behind a type synonym. E.g. + -- type Foo = forall a. Eq a => a -> a + -- id :: Foo + -- id x = x + -- Here we can't give a good location for the redundant constraints + -- (see lhsSigWcTypeContextSpan), so we don't report redundant + -- constraints at all. It's not clear that this a good choice; + -- perhaps we should report, just with a less informative SrcSpan. + -- c.f. #16154 + + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + ReportRedundantConstraints + | KindSigCtxt -- Kind signature + | StandaloneKindSigCtxt -- Standalone kind signature + Name -- Name of the type/class + | TypeAppCtxt -- Visible type application + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSynCtxt Name -- Type sig for a pattern synonym + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Class or types in a default declaration + | InstDeclCtxt Bool -- An instance declaration + -- True: stand-alone deriving + -- False: vanilla instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt Bool -- GHCi command :kind <type> + -- The Bool indicates if we are checking the outermost + -- type application. + -- See Note [Unsaturated type synonyms in GHCi] in + -- GHC.Tc.Validity. + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: <S> => a -> a + | DataTyCtxt Name -- The "stupid theta" part of a data decl + -- data <S> => T a = MkT a + | DerivClauseCtxt -- A 'deriving' clause + | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE + -- or SPECIALISE pragma + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | DataKindCtxt Name -- The kind of a data/newtype (instance) + | TySynKindCtxt Name -- The kind of the RHS of a type synonym + | TyFamResKindCtxt Name -- The result kind of a type family + deriving( Eq ) -- Just for checkSkolInfoAnon + +-- | Report Redundant Constraints. +data ReportRedundantConstraints + = NoRRC -- ^ Don't report redundant constraints + + | WantRRC SrcSpan -- ^ Report redundant constraints + -- The SrcSpan is for the constraints + -- E.g. f :: (Eq a, Ord b) => blah + -- The span is for the (Eq a, Ord b) + -- We need to record the span here because we have + -- long since discarded the HsType in favour of a Type + + deriving( Eq ) -- Just for checkSkolInfoAnon + +reportRedundantConstraints :: ReportRedundantConstraints -> Bool +reportRedundantConstraints NoRRC = False +reportRedundantConstraints (WantRRC {}) = True + +redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan +redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span +redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span +redundantConstraintsSpan _ = noSrcSpan + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. +-} + + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" +pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" +pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) +pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) +pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" +pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) + +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing + + +{- ********************************************************************* +* * + ErrCtxt +* * +********************************************************************* -} -------------------------------------------------------------------------------- -- type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) @@ -113,7 +268,7 @@ data ErrCtxtMsg -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. - | PatSigErrCtxt !TcType !TcType + | PatSigErrCtxt !TcType !ExpType -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -3,11 +3,6 @@ -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( - -- * UserTypeCtxt - UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, - ReportRedundantConstraints(..), reportRedundantConstraints, - redundantConstraintsSpan, - -- * SkolemInfo, SkolemInfoAnon SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, unkSkol, unkSkolAnon, isStaticSkolInfo, @@ -83,150 +78,6 @@ import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) -{- ********************************************************************* -* * - UserTypeCtxt -* * -********************************************************************* -} - -------------------------------------- --- | UserTypeCtxt describes the origin of the polymorphic type --- in the places where we need an expression to have that type -data UserTypeCtxt - = FunSigCtxt -- Function type signature, when checking the type - -- Also used for types in SPECIALISE pragmas - Name -- Name of the function - ReportRedundantConstraints - -- See Note [Tracking needed EvIds] in GHC.Tc.Solver - -- This field is usually 'WantRCC', but 'NoRCC' for - -- * Record selectors (not important here) - -- * Class and instance methods. Here the code may legitimately - -- be more polymorphic than the signature generated from the - -- class declaration - -- * Functions whose type signature has hidden the constraints - -- behind a type synonym. E.g. - -- type Foo = forall a. Eq a => a -> a - -- id :: Foo - -- id x = x - -- Here we can't give a good location for the redundant constraints - -- (see lhsSigWcTypeContextSpan), so we don't report redundant - -- constraints at all. It's not clear that this a good choice; - -- perhaps we should report, just with a less informative SrcSpan. - -- c.f. #16154 - - | InfSigCtxt Name -- Inferred type for function - | ExprSigCtxt -- Expression type signature - ReportRedundantConstraints - | KindSigCtxt -- Kind signature - | StandaloneKindSigCtxt -- Standalone kind signature - Name -- Name of the type/class - | TypeAppCtxt -- Visible type application - | ConArgCtxt Name -- Data constructor argument - | TySynCtxt Name -- RHS of a type synonym decl - | PatSynCtxt Name -- Type sig for a pattern synonym - | PatSigCtxt -- Type sig in pattern - -- eg f (x::t) = ... - -- or (x::t, y) = e - | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Class or types in a default declaration - | InstDeclCtxt Bool -- An instance declaration - -- True: stand-alone deriving - -- False: vanilla instance declaration - | SpecInstCtxt -- SPECIALISE instance pragma - | GenSigCtxt -- Higher-rank or impredicative situations - -- e.g. (f e) where f has a higher-rank type - -- We might want to elaborate this - | GhciCtxt Bool -- GHCi command :kind <type> - -- The Bool indicates if we are checking the outermost - -- type application. - -- See Note [Unsaturated type synonyms in GHCi] in - -- GHC.Tc.Validity. - - | ClassSCCtxt Name -- Superclasses of a class - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: <S> => a -> a - | DataTyCtxt Name -- The "stupid theta" part of a data decl - -- data <S> => T a = MkT a - | DerivClauseCtxt -- A 'deriving' clause - | TyVarBndrKindCtxt Name -- The kind of a type variable being bound - | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE - -- or SPECIALISE pragma - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... - | DataKindCtxt Name -- The kind of a data/newtype (instance) - | TySynKindCtxt Name -- The kind of the RHS of a type synonym - | TyFamResKindCtxt Name -- The result kind of a type family - deriving( Eq ) -- Just for checkSkolInfoAnon - --- | Report Redundant Constraints. -data ReportRedundantConstraints - = NoRRC -- ^ Don't report redundant constraints - - | WantRRC SrcSpan -- ^ Report redundant constraints - -- The SrcSpan is for the constraints - -- E.g. f :: (Eq a, Ord b) => blah - -- The span is for the (Eq a, Ord b) - -- We need to record the span here because we have - -- long since discarded the HsType in favour of a Type - - deriving( Eq ) -- Just for checkSkolInfoAnon - -reportRedundantConstraints :: ReportRedundantConstraints -> Bool -reportRedundantConstraints NoRRC = False -reportRedundantConstraints (WantRRC {}) = True - -redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan -redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span -redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span -redundantConstraintsSpan _ = noSrcSpan - -{- --- Notes re TySynCtxt --- We allow type synonyms that aren't types; e.g. type List = [] --- --- If the RHS mentions tyvars that aren't in scope, we'll --- quantify over them: --- e.g. type T = a->a --- will become type T = forall a. a->a --- --- With gla-exts that's right, but for H98 we should complain. --} - - -pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" -pprUserTypeCtxt KindSigCtxt = text "a kind signature" -pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) -pprUserTypeCtxt TypeAppCtxt = text "a type argument" -pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) -pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" -pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" -pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" -pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" -pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" -pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" -pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" -pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" -pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) -pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) -pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" -pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) -pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) - -isSigMaybe :: UserTypeCtxt -> Maybe Name -isSigMaybe (FunSigCtxt n _) = Just n -isSigMaybe (ConArgCtxt n) = Just n -isSigMaybe (ForSigCtxt n) = Just n -isSigMaybe (PatSynCtxt n) = Just n -isSigMaybe _ = Nothing - {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -5,7 +5,6 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data CtOrigin -data UserTypeCtxt data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -76,6 +76,8 @@ import GHC.Tc.Types.CtLoc , tyConAppRoleExplanation, appTyRoleExplanation ) import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..), ReportRedundantConstraints(..) + , pprUserTypeCtxt ) import GHC.Tc.Zonk.TcType import GHC.Tc.Utils.TcMType qualified as TcM ===================================== compiler/GHC/Tc/Validity.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types import GHC.Tc.Types.Constraint ( userTypeError_maybe ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cca9b8d98d6842b8a7c963499c175f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cca9b8d98d6842b8a7c963499c175f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] 6 commits: ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix
by Apoorv Ingle (＠ani) 26 Feb '26

26 Feb '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - c951fef1 by Cheng Shao at 2026-02-25T20:58:28+00:00 wasm: add /assets endpoint to serve user-specified assets This patch adds an `/assets` endpoint to the wasm dyld http server, so that users can also fetch assets from the same host with sensible default MIME types, without needing a separate http server for assets that also introduces CORS headaches: - A `-fghci-browser-assets-dir` driver flag is added to specify the assets root directory (defaults to `$PWD`) - The dyld http server fetches `mime-db` on demand and uses it as source of truth for mime types. Closes #26951. - - - - - dde22f97 by Sylvain Henry at 2026-02-26T13:14:03-05:00 Fix -fcheck-prim-bounds for non constant args (#26958) Previously we were only checking bounds for constant (literal) arguments! I've refactored the code to simplify the generation of out-of-line Cmm code for the primop composed of some inline code + some call to an external Cmm function. - - - - - 970c225a by Apoorv Ingle at 2026-02-26T16:35:29-06:00 Work for #25001 Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] ------------------------- Metric Decrease: T9020 ------------------------- * Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr` * Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Kills the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * Makes `splitHsApps` not look through `XExpr` * `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr` * Removes location information from `OrigPat` payload * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Rename `HsThingRn` to `SrcCodeCtxt` * Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack` * Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin` * Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression * Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax * Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * kill `PopErrCtxt` from `XXExprGhcRn` * simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself * fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) * rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location * fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg * Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack * `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex. This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them - The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead` - `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes * wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan * remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails` - - - - - 331aac39 by Apoorv Ingle at 2026-02-26T16:36:45-06:00 trying to remove SrcCodeOrigin - - - - - 123 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/wasm.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - libraries/base/src/Control/Arrow.hs - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - + testsuite/tests/codeGen/should_fail/T26958.hs - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - 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/template-haskell-exports.stdout - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d15033a07de586c45d1a38dd2eb6ff… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d15033a07de586c45d1a38dd2eb6ff… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 5 commits: ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix
by Apoorv Ingle (＠ani) 26 Feb '26

26 Feb '26

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - c951fef1 by Cheng Shao at 2026-02-25T20:58:28+00:00 wasm: add /assets endpoint to serve user-specified assets This patch adds an `/assets` endpoint to the wasm dyld http server, so that users can also fetch assets from the same host with sensible default MIME types, without needing a separate http server for assets that also introduces CORS headaches: - A `-fghci-browser-assets-dir` driver flag is added to specify the assets root directory (defaults to `$PWD`) - The dyld http server fetches `mime-db` on demand and uses it as source of truth for mime types. Closes #26951. - - - - - dde22f97 by Sylvain Henry at 2026-02-26T13:14:03-05:00 Fix -fcheck-prim-bounds for non constant args (#26958) Previously we were only checking bounds for constant (literal) arguments! I've refactored the code to simplify the generation of out-of-line Cmm code for the primop composed of some inline code + some call to an external Cmm function. - - - - - 970c225a by Apoorv Ingle at 2026-02-26T16:35:29-06:00 Work for #25001 Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] ------------------------- Metric Decrease: T9020 ------------------------- * Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr` * Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Kills the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * Makes `splitHsApps` not look through `XExpr` * `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr` * Removes location information from `OrigPat` payload * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Rename `HsThingRn` to `SrcCodeCtxt` * Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack` * Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin` * Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression * Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax * Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * kill `PopErrCtxt` from `XXExprGhcRn` * simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself * fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) * rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location * fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg * Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack * `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex. This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them - The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead` - `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes * wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan * remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails` - - - - - 113 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/wasm.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - libraries/base/src/Control/Arrow.hs - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - + testsuite/tests/codeGen/should_fail/T26958.hs - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - 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/template-haskell-exports.stdout - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d3e36b867ebdbcae291f0ddd5eb54… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d3e36b867ebdbcae291f0ddd5eb54… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] 33 commits: Linker.MacOS reduce dynflags import
by Apoorv Ingle (＠ani) 26 Feb '26

26 Feb '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 0e1cd2e0 by Evan Piro at 2026-02-08T10:35:16-08:00 Linker.MacOS reduce dynflags import - - - - - 1c79a4cd by Michael Alan Dorman at 2026-02-09T08:11:51-05:00 Remove `extra_src_files` variable from `testsuite/driver/testlib.py` While reading through the test harness code, I noticed this variable with a TODO attached that referenced #12223. Although that bug is closed, it strongly implied that this special-case variable that only affected a single test was expected to be removed at some point. I also looked at 3415bcaa0b1903b5e12dfaadb5b774718e406eab---where it was added---whose commit message suggested that it would have been desirable to remove it, but that there were special circumstances that meant it had to remain (though it doesn't elucidate what those special circumstances are). However, the special circumstances were mentioned as if the test was in a different location than is currently is, so I decided to try changing the test to use the standard `extra_files` mechanism, which works in local testing. This also seems like a reasonable time to remove the script that was originally used in the transition, since it doesn't really serve a purpose anymore. - - - - - 0020e38a by Matthew Pickering at 2026-02-09T17:29:14-05:00 determinism: Use a stable sort in WithHsDocIdentifiers binary instance `WithHsDocIdentifiers` is defined as ``` 71 data WithHsDocIdentifiers a pass = WithHsDocIdentifiers 72 { hsDocString :: !a 73 , hsDocIdentifiers :: ![Located (IdP pass)] 74 } ``` This list of names is populated from `rnHsDocIdentifiers`, which calls `lookupGRE`, which calls `lookupOccEnv_AllNameSpaces`, which calls `nonDetEltsUFM` and returns the results in an order depending on uniques. Sorting the list with a stable sort before returning the interface makes the output deterministic and follows the approach taken by other fields in `Docs`. Fixes #26858 - - - - - 89898ce6 by echoumcp1 at 2026-02-09T17:30:01-05:00 Replace putstrln with logMsg in handleSeqHValueStatus Fixes #26549 - - - - - 7c52c4f9 by John Paul Adrian Glaubitz at 2026-02-10T13:52:43-05:00 rts: Switch prim to use modern atomic compiler builtins The __sync_*() atomic compiler builtins have been deprecated in GCC for a while now and also don't provide variants for 64-bit values such as __sync_fetch_and_add_8(). Thus, replace them with the modern __atomic_*() compiler builtins and while we're at it, also drop the helper macro CAS_NAND() which is now no longer needed since we stopped using the __sync_*() compiler builtins altogether. Co-authored-by: Ilias Tsitsimpis <iliastsi(a)debian.org> Fixes #26729 - - - - - cf60850a by Recursion Ninja at 2026-02-10T13:53:27-05:00 Decoupling L.H.S.Decls from GHC.Types.ForeignCall - Adding TTG extension point for 'CCallTarget' - Adding TTG extension point for 'CType' - Adding TTG extension point for 'Header' - Moving ForeignCall types that do not need extension to new L.H.S.Decls.Foreign module - Replacing 'Bool' parameters with descriptive data-types to increase clairty and prevent "Boolean Blindness" - - - - - 11a04cbb by Eric Lee at 2026-02-11T09:20:46-05:00 Derive Semigroup/Monoid for instances believed could be derived in #25871 - - - - - 15d9ce44 by Eric Lee at 2026-02-11T09:20:46-05:00 add Ghc.Data.Pair deriving - - - - - c85dc170 by Evan Piro at 2026-02-11T09:21:45-05:00 Linker.MacOS reduce options import - - - - - a541dd83 by Chris Wendt at 2026-02-11T16:06:41-05:00 Initialize plugins for `:set +c` in GHCi Fixes #23110. - - - - - 0f5a73bc by Cheng Shao at 2026-02-11T16:07:27-05:00 compiler: add Binary Text instance This patch adds `Binary` instance for strict `Text`, in preparation of making `Text` usable in certain GHC API use cases (e.g. haddock). This also introduces `text` as a direct dependency of the `ghc` package. - - - - - 9e58b8a1 by Cheng Shao at 2026-02-11T16:08:10-05:00 ghc-toolchain: add C11 check This patch partially reverts commit b8307eab80c5809df5405d76c822bf86877f5960 that removed C99 check in autoconf/ghc-toolchain. Now we: - No longer re-implement `FP_SET_CFLAGS_C11` similar to `FP_SET_CFLAGS_C99` in the past, since autoconf doesn't provide a convenient `AC_PROG_CC_C11` function. ghc-toolchain will handle it anyway. - The Cmm CPP C99 check is relanded and repurposed for C11. - The C99 logic in ghc-toolchain is relanded and repurposed for C11. - The C99 check in Stg.h is corrected to check for C11. The obsolete _ISOC99_SOURCE trick is dropped. - Usages of `-std=gnu99` in the testsuite are corrected to use `-std=gnu11`. Closes #26908. - - - - - 4df0adf6 by Simon Peyton Jones at 2026-02-11T21:50:13-05:00 Simplify the treatment of static forms This MR implements GHC proposal 732: simplify static forms, https://github.com/ghc-proposals/ghc-proposals/pull/732 thereby addressing #26556. See `Note [Grand plan for static forms]` in GHC.Iface.Tidy.StaticPtrTable The main changes are: * There is a new, simple rule for (static e), namely that the free term variables of `e` must be bound at top level. The check is done in the `HsStatic` case of `GHC.Rename.Expr.rnExpr` * That in turn substantially simplifies the info that the typechecker carries around in its type environment. Hooray. * The desugarer emits static bindings to top level directly; see the `HsStatic` case of `dsExpr`. * There is no longer any special static-related magic in the FloatOut pass. And the main Simplifier pipeline no longer needs a special case to run FloatOut even with -O0. Hooray. All this forced an unexpected change to the pattern match checker. It recursively invokes the main Hs desugarer when it wants to take a look at a term to spot some special cases (notably constructor applications). We don't want to emit any nested (static e) bindings to top level a second time! Yikes. That forced a modest refactor in GHC.HsToCore.Pmc: * The `dsl_nablas` field of `DsLclEnv` now has a `NoPmc` case, which says "I'm desugaring just for pattern-match checking purposes". * When that flag is set we don't emit static binds. That in turn forces a cascade of refactoring, but the net effect is an improvement; less risk of duplicated (even exponential?) work. See Note [Desugaring HsExpr during pattern-match checking]. 10% metric decrease, on some architectures, of compile-time max-bytes-used on T15304. Metric Decrease: T15304 - - - - - 7922f728 by Teo Camarasu at 2026-02-11T21:50:58-05:00 ghc-internal: avoid depending on GHC.Internal.Exts This module is mostly just re-exports. It made sense as a user-facing module, but there's no good reason ghc-internal modules should depend on it and doing so linearises the module graph - move considerAccessible to GHC.Internal.Magic Previously it lived in GHC.Internal.Exts, but it really deserves to live along with the other magic function, which are already re-exported from .Exts - move maxTupleSize to GHC.Internal.Tuple This previously lived in GHC.Internal.Exts but a comment already said it should be moved to .Tuple Resolves #26832 - - - - - b6a4a29b by Eric Lee at 2026-02-11T21:51:55-05:00 Remove unused Semigroup imports to fix GHC 9.14 bootstrapping - - - - - 99d8c146 by Simon Peyton Jones at 2026-02-12T17:36:59+00:00 Fix subtle bug in cast worker/wrapper See (CWw4) in Note [Cast worker/wrapper]. The true payload is in the change to the definition of GHC.Types.Id.Info.hasInlineUnfolding Everthing else is just documentation. There is a 2% compile time decrease for T13056; I'll take the win! Metric Decrease: T13056 - - - - - 530e8e58 by Simon Peyton Jones at 2026-02-12T20:17:23-05:00 Add regression tests for four StaticPtr bugs Tickets #26545, #24464, #24773, #16981 are all solved by the recently-landed MR commit 318ee13bcffa6aa8df42ba442ccd92aa0f7e210c Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Oct 20 23:07:20 2025 +0100 Simplify the treatment of static forms This MR just adds regression tests for them. - - - - - 4157160f by Cheng Shao at 2026-02-13T06:27:04-05:00 ci: remove unused hlint-ghc-and-base job definition This patch removes the unused `hlint-ghc-and-base` job definition, it's never run since !9806. Note that hadrian lint rules still work locally, so anyone that wishes to run hlint on the codebase can continue to do so in their local worktree. - - - - - 039f1977 by Cheng Shao at 2026-02-13T06:27:47-05:00 wasm: use import.meta.main for proper distinction of nodejs main modules This patch uses `import.meta.main` for proper distinction of nodejs main modules, especially when the main module might be installed as a symlink. Fixes #26916. - - - - - 14f485ee by ARATA Mizuki at 2026-02-17T09:09:24+09:00 Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI Also, mark AVX-512 ER and PF as deprecated. AVX-512 instructions can be used for certain 64-bit integer vector operations. GFNI can be used to implement bitReverse (currently not used by NCG, but LLVM may use it). Closes #26406 Addresses #26509 - - - - - 016f79d5 by fendor at 2026-02-17T09:16:16-05:00 Hide implementation details from base exception stack traces Ensure we hide the implementation details of the exception throwing mechanisms: * `undefined` * `throwSTM` * `throw` * `throwIO` * `error` The `HasCallStackBacktrace` should always have a length of exactly 1, not showing internal implementation details in the stack trace, as these are vastly distracting to end users. CLC proposal [#387](https://github.com/haskell/core-libraries-committee/issues/387) - - - - - 4f2840f2 by Brian J. Cardiff at 2026-02-17T17:04:08-05:00 configure: Accept happy-2.2 In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build - - - - - 10b4d364 by Duncan Coutts at 2026-02-17T17:04:52-05:00 Fix errors in the documentation of the eventlog STOP_THREAD status codes Fix the code for BlockedOnMsgThrowTo. Document all the known historical warts. Fixes issue #26867 - - - - - c5e15b8b by Phil de Joux at 2026-02-18T05:07:36-05:00 haddock: use snippets for all list examples - generate snippet output for docs - reduce font size to better fit snippets - Use only directive to guard html snippets - Add latex snippets for lists - - - - - d388bac1 by Phil de Joux at 2026-02-18T05:07:36-05:00 haddock: Place the snippet input and output together - Put the output seemingly inside the example box - - - - - 016fa306 by Samuel Thibault at 2026-02-18T05:08:35-05:00 Fix linking against libm by moving the -lm option For those systems that need -lm for getting math functions, this is currently added on the link line very early, before the object files being linked together. Newer toolchains enable --as-needed by default, which means -lm is ignored at that point because no object requires a math function yet. With such toolchains, we thus have to add -lm after the objects, so the linker actually includes libm in the link. - - - - - 68bd0805 by Teo Camarasu at 2026-02-18T05:09:19-05:00 ghc-internal: Move GHC.Internal.Data.Bool to base This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression. Resolves 26865 - - - - - 4c40df3d by fendor at 2026-02-20T10:24:48-05:00 Add optional `SrcLoc` to `StackAnnotation` class `StackAnnotation`s give access to an optional `SrcLoc` field that user-added stack annotations can use to provide better backtraces in both error messages and when decoding the callstack. We update builtin stack annotations such as `StringAnnotation` and `ShowAnnotation` to also capture the `SrcLoc` of the current `CallStack` to improve backtraces by default (if stack annotations are used). This change is backwards compatible with GHC 9.14.1. - - - - - fd9aaa28 by Simon Hengel at 2026-02-20T10:25:33-05:00 docs: Fix grammar in explicit_namespaces.rst - - - - - 44354255 by Vo Minh Thu at 2026-02-20T18:53:06-05:00 GHCi: add a :version command. This looks like: ghci> :version GHCi, version 9.11.20240322 This closes #24576. Co-Author: Markus Läll <markus.l2ll(a)gmail.com> - - - - - eab3dbba by Andreas Klebinger at 2026-02-20T18:53:51-05:00 hadrian/build-cabal: Better respect and utilize -j * We now respect -j<n> for the cabal invocation to build hadrian rather than hardcoding -j * We use the --semaphore flag to ensure cabal/ghc build the hadrian executable in parallel using the -jsem mechanism. Saves 10-15s on fresh builds for me. Fixes #26876 - - - - - 7d3e36b8 by Apoorv Ingle at 2026-02-25T08:44:23-06:00 Work for #25001 Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] ------------------------- Metric Decrease: T9020 ------------------------- * Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr` * Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Kills the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * Makes `splitHsApps` not look through `XExpr` * `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr` * Removes location information from `OrigPat` payload * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Rename `HsThingRn` to `SrcCodeCtxt` * Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack` * Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin` * Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression * Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax * Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * kill `PopErrCtxt` from `XXExprGhcRn` * simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself * fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) * rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location * fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg * Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack * `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex. This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them - The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead` - `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes * wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan * remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails` - - - - - d15033a0 by Apoorv Ingle at 2026-02-26T16:31:44-06:00 trying to remove SrcCodeOrigin - - - - - 353 changed files: - .gitlab-ci.yml - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/CmmToAsm/Config.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Data/Pair.hs - compiler/GHC/Driver/Config/CmmToAsm.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/Decl.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/GuardedRHSs.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/SysTools/Cpp.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - − compiler/GHC/Tc/Utils/TcMType.hs-boot - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Types/Unique/DSet.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - compiler/GHC/Utils/Ppr/Colour.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - configure.ac - distrib/configure.ac.in - + docs/users_guide/10.0.1-notes.rst - docs/users_guide/9.16.1-notes.rst - docs/users_guide/eventlog-formats.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/ghci.rst - docs/users_guide/phases.rst - docs/users_guide/using.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - hadrian/build-cabal - libraries/base/changelog.md - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/CHANGELOG.md - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - + libraries/ghc-experimental/tests/Makefile - + libraries/ghc-experimental/tests/all.T - + libraries/ghc-experimental/tests/backtraces/Makefile - + libraries/ghc-experimental/tests/backtraces/T26806a.hs - + libraries/ghc-experimental/tests/backtraces/T26806a.stderr - + libraries/ghc-experimental/tests/backtraces/T26806b.hs - + libraries/ghc-experimental/tests/backtraces/T26806b.stderr - + libraries/ghc-experimental/tests/backtraces/T26806c.hs - + libraries/ghc-experimental/tests/backtraces/T26806c.stderr - + libraries/ghc-experimental/tests/backtraces/all.T - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim/Internal/Build.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - + libraries/ghc-internal/tests/backtraces/T15395.hs - + libraries/ghc-internal/tests/backtraces/T15395.stdout - libraries/ghc-internal/tests/backtraces/all.T - libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - m4/fp_cmm_cpp_cmd_with_args.m4 - m4/fptools_happy.m4 - rts/include/Stg.h - rts/prim/atomic.c - testsuite/driver/cpu_features.py - − testsuite/driver/kill_extra_files.py - testsuite/driver/testlib.py - testsuite/tests/arrows/should_compile/T21301.stderr - testsuite/tests/codeGen/should_gen_asm/all.T - + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.asm - + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.hs - + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.asm - + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.hs - + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.asm - + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.hs - testsuite/tests/codeGen/should_run/CgStaticPointers.hs - testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_fail/DsStrictFail.stderr - testsuite/tests/deSugar/should_run/T20024.stderr - testsuite/tests/deSugar/should_run/dsrun005.stderr - testsuite/tests/deSugar/should_run/dsrun007.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - testsuite/tests/deriving/should_run/T9576.stderr - testsuite/tests/ffi/should_run/all.T - testsuite/tests/ghci/scripts/Defer02.stderr - testsuite/tests/ghci/scripts/T15325.stderr - testsuite/tests/ghci/scripts/T20150.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/patsyn/should_run/ghci.stderr - + testsuite/tests/plugins/T23110.hs - + testsuite/tests/plugins/T23110.script - + testsuite/tests/plugins/T23110.stdout - testsuite/tests/plugins/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/process/all.T - testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr - testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr - + testsuite/tests/rename/should_fail/T26545.hs - + testsuite/tests/rename/should_fail/T26545.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26903.hs - + testsuite/tests/simplCore/should_compile/T26903.stderr - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/type-data/should_run/T22332a.stderr - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - + testsuite/tests/typecheck/should_compile/T24464.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - testsuite/tests/typecheck/should_run/T10284.stderr - testsuite/tests/typecheck/should_run/T13838.stderr - + testsuite/tests/typecheck/should_run/T16981.hs - + testsuite/tests/typecheck/should_run/T16981.stdout - + testsuite/tests/typecheck/should_run/T24773.hs - + testsuite/tests/typecheck/should_run/T24773.stdout - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - testsuite/tests/typecheck/should_run/all.T - testsuite/tests/unsatisfiable/T23816.stderr - testsuite/tests/unsatisfiable/UnsatDefer.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/haddock/doc/.gitignore - utils/haddock/doc/Makefile - + utils/haddock/doc/_static/haddock-custom.css - utils/haddock/doc/conf.py - utils/haddock/doc/markup.rst - + utils/haddock/doc/snippets/.gitignore - + utils/haddock/doc/snippets/Lists.hs - + utils/haddock/doc/snippets/Makefile - + utils/haddock/doc/snippets/Snippet-List-Bulleted.html - + utils/haddock/doc/snippets/Snippet-List-Bulleted.tex - + utils/haddock/doc/snippets/Snippet-List-Definition.html - + utils/haddock/doc/snippets/Snippet-List-Definition.tex - + utils/haddock/doc/snippets/Snippet-List-Enumerated.html - + utils/haddock/doc/snippets/Snippet-List-Enumerated.tex - + utils/haddock/doc/snippets/Snippet-List-Indentation.html - + utils/haddock/doc/snippets/Snippet-List-Indentation.tex - + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.html - + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.tex - + utils/haddock/doc/snippets/Snippet-List-Nested-Item.html - + utils/haddock/doc/snippets/Snippet-List-Nested-Item.tex - + utils/haddock/doc/snippets/Snippet-List-Not-Newline.html - + utils/haddock/doc/snippets/Snippet-List-Not-Newline.tex - + utils/haddock/doc/snippets/Snippet-List-Not-Separated.html - + utils/haddock/doc/snippets/Snippet-List-Not-Separated.tex - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/html-test/ref/A.html - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug1033.html - utils/haddock/html-test/ref/Bug1103.html - utils/haddock/html-test/ref/Bug548.html - utils/haddock/html-test/ref/Bug923.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/FunArgs.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/Instances.html - utils/haddock/html-test/ref/LinearTypes.html - utils/haddock/html-test/ref/RedactTypeSynonyms.html - utils/haddock/html-test/ref/T23616.html - utils/haddock/html-test/ref/Test.html - utils/haddock/html-test/ref/TypeFamilies3.html - utils/jsffi/dyld.mjs - utils/jsffi/post-link.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4800bc7c37b8085d840c3e41cbd1f2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4800bc7c37b8085d840c3e41cbd1f2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] Fix stripping: Not for >= Stage2 cross-compiled
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: f4503bbf by Sven Tennie at 2026-02-26T21:30:52+00:00 Fix stripping: Not for >= Stage2 cross-compiled - - - - - 1 changed file: - hadrian/src/Settings/Builders/Cabal.hs Changes: ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -90,9 +90,10 @@ commonCabalArgs stage = do -- we might have issues with stripping on Windows, as I can't see a -- consumer of 'stripCmdPath'. -- TODO: See https://github.com/snowleopard/hadrian/issues/549. - -- TODO: MP should check per-stage rather than a global CrossCompiling, but not going to cause bugs - flag CrossCompiling ? pure [ "--disable-executable-stripping" - , "--disable-library-stripping" ] + -- Do not try to strip cross-compiled libs, we can't do this, yet. + andM [flag CrossCompiling, pure (stage >= Stage2)] ? + pure [ "--disable-executable-stripping" + , "--disable-library-stripping" ] -- We don't want to strip the debug RTS , S.package rts ? pure [ "--disable-executable-stripping" , "--disable-library-stripping" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4503bbfdb2415c4175b79c2f11d6ba… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4503bbfdb2415c4175b79c2f11d6ba… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 3 commits: Cleanup inTreeCompilerArgs
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 66c56061 by Sven Tennie at 2026-02-26T20:59:39+00:00 Cleanup inTreeCompilerArgs - - - - - 43662196 by Sven Tennie at 2026-02-26T20:59:39+00:00 Cleanup isOptional - - - - - 122df994 by Sven Tennie at 2026-02-26T21:16:44+00:00 Fix stripping: Not for >= Stage2 cross-compiled - - - - - 3 changed files: - hadrian/src/Builder.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -415,8 +415,7 @@ isOptional target = \case Alex -> True -- Most ar implemententions no longer need ranlib, but some still do Ranlib {} -> not $ Toolchain.arNeedsRanlib (tgtAr target) - -- TODO: Use stage argument - JsCpp {} -> not $ (archOS_arch . tgtArchOs) target == ArchJavaScript -- ArchWasm32 too? + JsCpp {} -> (archOS_arch . tgtArchOs) target /= ArchJavaScript -- ArchWasm32 too? _ -> False -- | Determine the location of a system 'Builder'. ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -90,9 +90,10 @@ commonCabalArgs stage = do -- we might have issues with stripping on Windows, as I can't see a -- consumer of 'stripCmdPath'. -- TODO: See https://github.com/snowleopard/hadrian/issues/549. - -- TODO: MP should check per-stage rather than a global CrossCompiling, but not going to cause bugs - flag CrossCompiling ? pure [ "--disable-executable-stripping" - , "--disable-library-stripping" ] + -- Do not try to strip cross-compiled libs, we can't do this, yet. + andM [flag CrossCompiling, pure (stage >= Stage2)]] ? + pure [ "--disable-executable-stripping" + , "--disable-library-stripping" ] -- We don't want to strip the debug RTS , S.package rts ? pure [ "--disable-executable-stripping" , "--disable-library-stripping" ] ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -105,50 +105,49 @@ allowHaveLLVM = not . (`elem` ["wasm32", "javascript"]) -- inTreeCompilerArgs :: Stage -> Action TestCompilerArgs inTreeCompilerArgs stg = do - -- TODO: executable and library stage would be clearer cross <- crossStage stg - let ghcStage = succStage stg - pkgCacheStage = if cross then ghcStage else stg + let executableStage = succStage stg + libraryStage = if cross then executableStage else stg (hasDynamicRts, hasThreadedRts) <- do - ways <- interpretInContext (vanillaContext ghcStage rts) getRtsWays + ways <- interpretInContext (vanillaContext executableStage rts) getRtsWays return (dynamic `elem` ways, threaded `elem` ways) - hasDynamic <- (wayUnit Dynamic) . Context.Type.way <$> (programContext stg ghc) - leadingUnderscore <- queryTargetTarget ghcStage tgtSymbolsHaveLeadingUnderscore - withInterpreter <- ghcWithInterpreter ghcStage - unregisterised <- queryTargetTarget ghcStage tgtUnregisterised - tables_next_to_code <- queryTargetTarget ghcStage tgtTablesNextToCode - targetWithSMP <- targetSupportsSMP ghcStage - interpForceDyn <- targetRTSLinkerOnlySupportsSharedLibs ghcStage - - debugAssertions <- ghcDebugAssertions <$> flavour <*> pure ghcStage - debugged <- ghcDebugged <$> flavour <*> pure ghcStage - profiled <- ghcProfiled <$> flavour <*> pure ghcStage + hasDynamic <- wayUnit Dynamic . Context.Type.way <$> programContext stg ghc + leadingUnderscore <- queryTargetTarget executableStage tgtSymbolsHaveLeadingUnderscore + withInterpreter <- ghcWithInterpreter executableStage + unregisterised <- queryTargetTarget executableStage tgtUnregisterised + tables_next_to_code <- queryTargetTarget executableStage tgtTablesNextToCode + targetWithSMP <- targetSupportsSMP executableStage + interpForceDyn <- targetRTSLinkerOnlySupportsSharedLibs executableStage + + debugAssertions <- ghcDebugAssertions <$> flavour <*> pure executableStage + debugged <- ghcDebugged <$> flavour <*> pure executableStage + profiled <- ghcProfiled <$> flavour <*> pure executableStage os <- queryHostTarget queryOS - arch <- queryTargetTarget ghcStage queryArch + arch <- queryTargetTarget executableStage queryArch let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32", "riscv64", "loongarch64"] let withNativeCodeGen | unregisterised = False | arch `elem` codegen_arches = True | otherwise = False - platform <- queryTargetTarget ghcStage targetPlatformTriple - wordsize <- show @Int . (*8) <$> queryTargetTarget ghcStage (wordSize2Bytes . tgtWordSize) + platform <- queryTargetTarget executableStage targetPlatformTriple + wordsize <- show @Int . (*8) <$> queryTargetTarget executableStage (wordSize2Bytes . tgtWordSize) - llc_cmd <- queryTargetTarget ghcStage tgtLlc - llvm_as_cmd <- queryTargetTarget ghcStage tgtLlvmAs + llc_cmd <- queryTargetTarget executableStage tgtLlc + llvm_as_cmd <- queryTargetTarget executableStage tgtLlvmAs let have_llvm = allowHaveLLVM arch && all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory pkgConfCacheFile <- System.FilePath.normalise . (top -/-) - <$> (packageDbPath (PackageDbLoc pkgCacheStage Final) <&> (-/- "package.cache")) + <$> (packageDbPath (PackageDbLoc libraryStage Final) <&> (-/- "package.cache")) libdir <- System.FilePath.normalise . (top -/-) - <$> stageLibPath pkgCacheStage + <$> stageLibPath libraryStage -- For this information, we need to query ghc --info, however, that would -- require building ghc, which we don't want to do here. Therefore, the -- logic from `platformHasRTSLinker` is duplicated here. - let rtsLinker = not $ arch `elem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "loongarch64", "javascript"] + let rtsLinker = arch `notElem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "loongarch64", "javascript"] return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8dc900bb1a28b16c8bee5f16cfe675… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8dc900bb1a28b16c8bee5f16cfe675… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Remove in-package dependencies on `GHC.Internal.System.IO`
by Wolfgang Jeltsch (＠jeltsch) 26 Feb '26

26 Feb '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC Commits: 416e4108 by Wolfgang Jeltsch at 2026-02-26T20:58:09+02:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Move some `IsString` instance declarations into `base` * Move the `* -> *` `Heap.Closure` instances into `ghc-heap` * Move some code that needs `System.IO` to `template-haskell` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `GHCi.Helpers` implementation into `base` * Move the `System.IO.OS` implementation into `base` - - - - - 20 changed files: - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/GHCi/Helpers.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - − libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/typecheck/should_fail/T12921.stderr Changes: ===================================== libraries/base/src/GHC/Fingerprint.hs ===================================== @@ -9,3 +9,45 @@ module GHC.Fingerprint ( ) where import GHC.Internal.Fingerprint + +import Data.Function (($)) +import Control.Monad (return, when) +import Data.Bool (not, (&&)) +import Data.List ((++)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.Int (Int) +import Data.Word (Word8) +import Data.Eq ((/=)) +import Text.Show (show) +import System.IO + ( + IO, + FilePath, + IOMode (ReadMode), + withBinaryFile, + hGetBuf, + hIsEOF + ) +import Foreign.Ptr (Ptr) +import GHC.Err (errorWithoutStackTrace) + +-- | Computes the hash of a given file. +-- This function runs in constant memory. +-- +-- @since base-4.7.0.0 +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \ hdl -> + let + readChunk :: Ptr Word8 -> Int -> IO (Maybe Int) + readChunk bufferPtr bufferSize = do + chunkSize <- hGetBuf hdl bufferPtr bufferSize + isFinished <- hIsEOF hdl + when (chunkSize /= bufferSize && not isFinished) + ( + errorWithoutStackTrace $ + "GHC.Fingerprint.getFileHash: could only read " ++ + show chunkSize ++ + " bytes, but more are available" + ) + return (if isFinished then Just chunkSize else Nothing) + in fingerprintBufferedStream readChunk ===================================== libraries/base/src/GHC/GHCi/Helpers.hs ===================================== @@ -24,4 +24,30 @@ module GHC.GHCi.Helpers evalWrapper ) where -import GHC.Internal.GHCi.Helpers \ No newline at end of file +import Data.String (String) +import System.IO + ( + IO, + BufferMode (NoBuffering), + hSetBuffering, + hFlush, + stdin, + stdout, + stderr + ) +import System.Environment (withProgName, withArgs) + +disableBuffering :: IO () +disableBuffering = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + +flushAll :: IO () +flushAll = do + hFlush stdout + hFlush stderr + +evalWrapper :: String -> [String] -> IO a -> IO a +evalWrapper progName args m = + withProgName progName (withArgs args m) ===================================== libraries/base/src/GHC/ResponseFile.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Safe #-} -- | @@ -19,4 +20,145 @@ module GHC.ResponseFile ( expandResponse ) where -import GHC.Internal.ResponseFile +import Control.Monad (return, (>>=), mapM) +import Control.Exception (IOException, catch) +import Data.Function (($), (.)) +import Data.Bool (Bool (False, True), otherwise, not, (||)) +import Data.Char (Char, isSpace) +import Data.List ((++), map, filter, concat, reverse) +import Data.String (String, unlines) +import Data.Functor (fmap) +import Data.Foldable (null, foldl') +import Data.Eq ((==)) +import Text.Show (show) +import System.Environment (getArgs) +import System.IO (IO, hPutStrLn, readFile, stderr) +import System.Exit (exitFailure) + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechanism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like @\@foo@ will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -21,4 +21,67 @@ module System.Exit die ) where -import GHC.Internal.System.Exit \ No newline at end of file +import GHC.IO.Exception + ( + IOErrorType (InvalidArgument), + IOException (IOError), + ExitCode (ExitSuccess, ExitFailure) + ) +import Control.Monad ((>>)) +import Control.Exception (throwIO, ioError) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Nothing)) +import Data.String (String) +import Data.Eq ((/=)) +import System.IO (IO, hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be +-- caught using the functions of "Control.Exception". This means that +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from +-- "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since base-4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-| This module bridges between Haskell handles and underlying operating-system @@ -21,17 +23,293 @@ module System.IO.OS ) where -import GHC.Internal.System.IO.OS +import Control.Monad (return) +import Control.Concurrent.MVar (MVar) +import Control.Exception (mask) +import Data.Function (const, (.), ($)) +import Data.Functor (fmap) +import Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Just)) +#endif +import Data.List ((++)) +import Data.String (String) +import Data.Typeable (Typeable, cast) +import System.IO (IO) +import GHC.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.IO.Windows.Handle ( - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE ) +#endif +import GHC.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import Foreign.Ptr (Ptr) +import 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 ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box. @@ -42,3 +37,23 @@ module GHC.Exts.Heap.Closures ( ) where import GHC.Internal.Heap.Closures + +import GHC.Internal.Data.Functor +import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Traversable + +deriving instance Functor GenClosure +deriving instance Foldable GenClosure +deriving instance Traversable GenClosure + +deriving instance Functor GenStgStackClosure +deriving instance Foldable GenStgStackClosure +deriving instance Traversable GenStgStackClosure + +deriving instance Functor GenStackField +deriving instance Foldable GenStackField +deriving instance Traversable GenStackField + +deriving instance Functor GenStackFrame +deriving instance Foldable GenStackFrame +deriving instance Traversable GenStackFrame ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -228,7 +228,6 @@ Library GHC.Internal.ForeignPtr GHC.Internal.Functor.ZipList GHC.Internal.GHCi - GHC.Internal.GHCi.Helpers GHC.Internal.Generics GHC.Internal.Heap.Closures GHC.Internal.Heap.Constants @@ -284,7 +283,6 @@ Library GHC.Internal.Read GHC.Internal.Real GHC.Internal.Records - GHC.Internal.ResponseFile GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST @@ -323,10 +321,8 @@ Library GHC.Internal.Numeric.Natural GHC.Internal.System.Environment GHC.Internal.System.Environment.Blank - 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/Data/Version.hs ===================================== @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..), (&&) ) +import GHC.Internal.Base ( Applicative(..), (&&), String ) import GHC.Internal.Generics import GHC.Internal.Unicode ( isDigit, isAlphaNum ) import GHC.Internal.Read ===================================== libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs ===================================== @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint ( fingerprintData, fingerprintString, fingerprintFingerprints, - getFileHash + fingerprintBufferedStream ) where import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.Bits import GHC.Internal.Num +import GHC.Internal.Data.Maybe import GHC.Internal.List import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Foreign.Storable -import GHC.Internal.System.IO import GHC.Internal.Fingerprint.Type @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $ fromIntegral (w32 `shiftR` 8), fromIntegral w32] --- | Computes the hash of a given file. --- This function loops over the handle, running in constant memory. --- --- @since base-4.7.0.0 -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> +-- | Reads data in chunks and computes its hash. +-- This function runs in constant memory. +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) + -> IO Fingerprint +fingerprintBufferedStream readChunk = allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do c_MD5Init pctxt - - processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size)) - + allocaBytes _BUFSIZE $ \arrPtr -> + let loop = do + maybeRemainderSize <- readChunk arrPtr _BUFSIZE + c_MD5Update pctxt + arrPtr + (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize)) + when (isNothing maybeRemainderSize) loop + in loop allocaBytes 16 $ \pdigest -> do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) - where _BUFSIZE = 4096 - -- Loop over _BUFSIZE sized chunks read from the handle, - -- passing the callback a block of bytes and its size. - processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () - processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> - - let loop = do - count <- hGetBuf h arrPtr _BUFSIZE - eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ - "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" - - f arrPtr count - - when (not eof) loop - - in loop - data MD5Context foreign import ccall unsafe "__hsbase_MD5Init" ===================================== libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs deleted ===================================== @@ -1,44 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.GHCi.Helpers --- Copyright : (c) The GHC Developers --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Various helpers used by the GHCi shell. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- ------------------------------------------------------------------------------ - -module GHC.Internal.GHCi.Helpers - ( disableBuffering, flushAll - , evalWrapper - ) where - -import GHC.Internal.Base -import GHC.Internal.System.IO -import GHC.Internal.System.Environment - -disableBuffering :: IO () -disableBuffering = do - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - hSetBuffering stderr NoBuffering - -flushAll :: IO () -flushAll = do - hFlush stdout - hFlush stderr - -evalWrapper :: String -> [String] -> IO a -> IO a -evalWrapper progName args m = - withProgName progName (withArgs args m) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -5,7 +5,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box. -- This can be removed once our boot compiler is no longer affected by #25212 @@ -69,8 +68,7 @@ in the profiling way. (#15197) import GHC.Internal.Heap.ProfInfo.Types import GHC.Internal.Data.Bits -import GHC.Internal.Data.Foldable (Foldable, toList) -import GHC.Internal.Data.Traversable (Traversable) +import GHC.Internal.Data.Foldable (toList) import GHC.Internal.Int import GHC.Internal.Num import GHC.Internal.Real @@ -383,7 +381,7 @@ data GenClosure b -- or an Int#). | UnknownTypeWordSizedPrimitive { wordVal :: !Word } - deriving (Show, Generic, Functor, Foldable, Traversable) + deriving (Show, Generic) -- | Get the info table for a heap closure, or Nothing for a prim value -- @@ -500,7 +498,7 @@ data GenStgStackClosure b = GenStgStackClosure , ssc_stack_size :: !Word32 -- ^ stack size in *words* , ssc_stack :: ![GenStackFrame b] } - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) type StackField = GenStackField Box @@ -510,7 +508,7 @@ data GenStackField b = StackWord !Word -- | A pointer field | StackBox !b - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) type StackFrame = GenStackFrame Box @@ -579,7 +577,7 @@ data GenStackFrame b = { info_tbl :: !StgInfoTable , annotation :: !b } - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) data PrimType = PInt ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted ===================================== @@ -1,163 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.ResponseFile --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : internal --- Portability : portable --- --- GCC style response files. --- --- @since base-4.12.0.0 ----------------------------------------------------------------------------- - --- Migrated from Haddock. - -module GHC.Internal.ResponseFile ( - getArgsWithResponseFiles, - unescapeArgs, - escapeArgs, escapeArg, - expandResponse - ) where - -import GHC.Internal.Control.Exception -import GHC.Internal.Data.Foldable (Foldable(..)) -import GHC.Internal.Base -import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) -import GHC.Internal.Text.Show (show) -import GHC.Internal.System.Environment (getArgs) -import GHC.Internal.System.Exit (exitFailure) -import GHC.Internal.System.IO - -{-| -Like 'getArgs', but can also read arguments supplied via response files. - - -For example, consider a program @foo@: - -@ -main :: IO () -main = do - args <- getArgsWithResponseFiles - putStrLn (show args) -@ - - -And a response file @args.txt@: - -@ ---one 1 ---\'two\' 2 ---"three" 3 -@ - -Then the result of invoking @foo@ with @args.txt@ is: - -> > ./foo @args.txt -> ["--one","1","--two","2","--three","3"] - --} -getArgsWithResponseFiles :: IO [String] -getArgsWithResponseFiles = getArgs >>= expandResponse - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechanism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like @\@foo@ will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted ===================================== @@ -1,81 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.System.Exit --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : provisional --- Portability : portable --- --- Exiting the program. --- ------------------------------------------------------------------------------ - -module GHC.Internal.System.Exit - ( - ExitCode(ExitSuccess,ExitFailure) - , exitWith - , exitFailure - , exitSuccess - , die - ) where - -import GHC.Internal.System.IO - -import GHC.Internal.Base -import GHC.Internal.IO -import GHC.Internal.IO.Exception - --- --------------------------------------------------------------------------- --- exitWith - --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. --- Normally this terminates the program, returning @code@ to the --- program's caller. --- --- On program termination, the standard 'Handle's 'stdout' and --- 'stderr' are flushed automatically; any other buffered 'Handle's --- need to be flushed manually, otherwise the buffered data will be --- discarded. --- --- A program that fails in any other way is treated as if it had --- called 'exitFailure'. --- A program that terminates successfully without calling 'exitWith' --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. --- --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be --- caught using the functions of "Control.Exception". This means that --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from --- "Control.Exception") are also executed properly on 'exitWith'. --- --- Note: in GHC, 'exitWith' should be called from the main program --- thread in order to exit the process. When called from another --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the --- exception will not cause the process itself to exit. --- -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO ExitSuccess -exitWith code@(ExitFailure n) - | n /= 0 = throwIO code - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) - --- | The computation 'exitFailure' is equivalent to --- 'exitWith' @(@'ExitFailure' /exitfail/@)@, --- where /exitfail/ is implementation-dependent. -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- | The computation 'exitSuccess' is equivalent to --- 'exitWith' 'ExitSuccess', It terminates the program --- successfully. -exitSuccess :: IO a -exitSuccess = exitWith ExitSuccess - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since base-4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted ===================================== @@ -1,323 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# 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 - -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (otherwise) -#endif -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) -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. --} ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad import Prelude import Data.Data hiding (Fixity(..)) import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO ( hPutStrLn, stderr ) +import System.IO (FilePath, hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) -import GHC.Types (TYPE, RuntimeRep(..)) +import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.Traversable import GHC.Internal.IORef -import GHC.Internal.System.IO +import GHC.Internal.IO (FilePath) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stderr) import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix) addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is recommended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignSource LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignSource :: ForeignSrcLang -> String -> Q () -addForeignSource lang src = do - let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" - LangObjcxx -> "mm" - LangAsm -> "s" - LangJs -> "js" - RawObject -> "a" - path <- addTempFile suffix - runIO $ writeFile path src - addForeignFilePath lang path - -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in -- conjunction with 'addTempFile'. ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) -- This module completely re-exports 'GHC.Boot.TH.Syntax', --- and exports additionally functions that depend on filepath. +-- and exports additionally functions that depend on @filepath@ or @System.IO@. -- | addForeignFile :: ForeignSrcLang -> String -> Q () @@ -218,6 +218,37 @@ addForeignFile = addForeignSource "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is recommended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignSource LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + LangAsm -> "s" + LangJs -> "js" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -11190,8 +11190,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 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’ instance forall a. GHC.Internal.Enum.Bounded a => GHC.Internal.Enum.Bounded (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. (GHC.Internal.Enum.Enum a, GHC.Internal.Enum.Bounded a, GHC.Internal.Classes.Eq a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -11193,8 +11193,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 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’ instance forall a. GHC.Internal.Enum.Bounded a => GHC.Internal.Enum.Bounded (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. (GHC.Internal.Enum.Enum a, GHC.Internal.Enum.Bounded a, GHC.Internal.Classes.Eq a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -2,6 +2,7 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote +interfacePlugin: Data.List interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/typecheck/should_fail/T12921.stderr ===================================== @@ -24,8 +24,6 @@ T12921.hs:4:16: error: [GHC-39999] Potentially matching instance: instance (a ~ Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ - ...plus two instances involving out-of-scope types - (use -fprint-potential-instances to see them all) • In the annotation: {-# ANN module "HLint: ignore Reduce duplication" #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/416e4108d537bc8c3fe2f55b4207ef1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/416e4108d537bc8c3fe2f55b4207ef1… 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: Fix -fcheck-prim-bounds for non constant args (#26958)
by Marge Bot (＠marge-bot) 26 Feb '26

26 Feb '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: dde22f97 by Sylvain Henry at 2026-02-26T13:14:03-05:00 Fix -fcheck-prim-bounds for non constant args (#26958) Previously we were only checking bounds for constant (literal) arguments! I've refactored the code to simplify the generation of out-of-line Cmm code for the primop composed of some inline code + some call to an external Cmm function. - - - - - 9543f010 by Vladislav Zavialov at 2026-02-26T13:47:09-05:00 Check for negative type literals in the type checker (#26861) GHC disallows negative type literals (e.g., -1), as tested by T8306 and T8412. This check is currently performed in the renamer: rnHsTyLit tyLit@(HsNumTy x i) = do when (i < 0) $ addErr $ TcRnNegativeNumTypeLiteral tyLit However, this check can be bypassed using RequiredTypeArguments (see the new test case T26861). Prior to this patch, such programs caused the compiler to hang instead of reporting a proper error. This patch addresses the issue by adding an equivalent check in the type checker, namely in tcHsType. The diff is deliberately minimal to facilitate backporting. A more comprehensive rework of HsTyLit is planned for a separate commit. - - - - - 21828b58 by Vladislav Zavialov at 2026-02-26T13:47:10-05:00 Consistent pretty-printing of HsString, HsIsString, HsStrTy Factor out a helper to pretty-print string literals, thus fixing newline handling for overloaded string literals and type literals. Test cases: T26860ppr T26860ppr_overloaded T26860ppr_tylit Follow up to ddf1434ff9bb08cfef3c93f23de6b83ec698aa27 - - - - - 14 changed files: - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/Tc/Gen/HsType.hs - + testsuite/tests/codeGen/should_fail/T26958.hs - testsuite/tests/codeGen/should_fail/all.T - + testsuite/tests/parser/should_fail/T26860ppr_overloaded.hs - + testsuite/tests/parser/should_fail/T26860ppr_overloaded.stderr - + testsuite/tests/parser/should_fail/T26860ppr_tylit.hs - + testsuite/tests/parser/should_fail/T26860ppr_tylit.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/typecheck/should_fail/T26861.hs - + testsuite/tests/typecheck/should_fail/T26861.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import GHC.Data.FastString (unpackFS) +import GHC.Data.FastString (FastString, unpackFS) import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText @@ -209,10 +209,7 @@ Equivalently it's True if instance IsPass p => Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) - ppr (HsString st s) = - case st of - NoSourceText -> pprHsString s - SourceText src -> vcat $ map text $ split '\n' (unpackFS src) + ppr (HsString st s) = pprHsStringLit st s ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) = pprWithSourceText (il_text i) (integer (il_value i)) @@ -233,6 +230,10 @@ instance IsPass p => Outputable (HsLit (GhcPass p)) where (HsInteger st i _) -> pprWithSourceText st (integer i) (HsRat f _) -> ppr f +pprHsStringLit :: SourceText -> FastString -> SDoc +pprHsStringLit NoSourceText s = pprHsString s +pprHsStringLit (SourceText src) _ = vcat $ map text $ split '\n' (unpackFS src) + -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p => Outputable (HsOverLit (GhcPass p)) where @@ -242,7 +243,7 @@ instance OutputableBndrId p instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsIsString st s) = pprHsStringLit st s negateOverLitVal :: OverLitVal -> OverLitVal negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -116,6 +116,7 @@ import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Hs.Doc +import GHC.Hs.Lit (pprHsStringLit) import GHC.Generics (Generic, Generically(..)) import GHC.Types.Basic import GHC.Types.SrcLoc @@ -1346,7 +1347,7 @@ instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) -ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsStrTy source s) = pprHsStringLit source s ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) pprAnonWildCard :: SDoc ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -87,17 +87,27 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind -cmmPrimOpApp cfg primop cmm_args mres_ty = - case emitPrimOp cfg primop cmm_args of - PrimopCmmEmit_Internal f -> - let - -- if the result type isn't explicitly given, we directly use the - -- result type of the primop. - res_ty = fromMaybe (primOpResultType primop) mres_ty - in emitReturn =<< f res_ty - PrimopCmmEmit_External -> do - let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - emitCall (NativeNodeCall, NativeReturn) fun cmm_args +cmmPrimOpApp cfg primop cmm_args mres_ty = do + let PrimopCmmEmit _inline f = emitPrimOp cfg primop cmm_args + let + -- if the result type isn't explicitly given, we directly use the + -- result type of the primop. + res_ty = fromMaybe (primOpResultType primop) mres_ty + f res_ty + +externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit +externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args) + +outOfLinePrimop :: FCode ReturnKind -> PrimopCmmEmit +outOfLinePrimop code = PrimopCmmEmit + { primopCmmInline = False + , primopCmmCode = \_res_ty -> code + } + +callExternalPrimop :: PrimOp -> [CmmExpr] -> FCode ReturnKind +callExternalPrimop primop args = do + let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + emitCall (NativeNodeCall, NativeReturn) fun args -- | Interpret the argument as an unsigned value, assuming the value @@ -121,8 +131,7 @@ asUnsigned w n = n .&. (bit (widthInBits w) - 1) shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of - PrimopCmmEmit_External -> False - PrimopCmmEmit_Internal _ -> True + PrimopCmmEmit inline _ -> inline -- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use -- ByteOff (or some other fixed width signed type) to represent @@ -153,103 +162,135 @@ emitPrimOp cfg primop = NewByteArrayOp_Char -> \case [(CmmLit (CmmInt n w))] | asUnsigned w n <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> doNewByteArrayOp res (fromInteger n) + args -> externalPrimop primop args NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel + -> inlinePrimop $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init - _ -> PrimopCmmEmit_External + args -> externalPrimop primop args CopyArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External + inlinePrimop $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + [src, src_off, dst, dst_off, n] -> + outOfLinePrimop $ do + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (ptrArraySize platform profile src) + emitRangeBoundsCheck dst_off n (ptrArraySize platform profile dst) + callExternalPrimop CopyArrayOp [src, src_off, dst, dst_off, n] + _ -> panic "CopyArrayOp" CopyMutableArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External + inlinePrimop $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + [src, src_off, dst, dst_off, n] -> + outOfLinePrimop $ do + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (ptrArraySize platform profile src) + emitRangeBoundsCheck dst_off n (ptrArraySize platform profile dst) + callExternalPrimop CopyMutableArrayOp [src, src_off, dst, dst_off, n] + _ -> panic "CopyMutableArrayOp" CloneArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args CloneMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args FreezeArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args ThawArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args NewSmallArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> + -> inlinePrimop $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] (fromInteger n) init - _ -> PrimopCmmEmit_External + args -> externalPrimop primop args CopySmallArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External + inlinePrimop $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) + [src, src_off, dst, dst_off, n] -> + outOfLinePrimop $ do + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (smallPtrArraySize platform profile src) + emitRangeBoundsCheck dst_off n (smallPtrArraySize platform profile dst) + callExternalPrimop CopySmallArrayOp [src, src_off, dst, dst_off, n] + _ -> panic "CopySmallArrayOp" CopySmallMutableArrayOp -> \case [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External + inlinePrimop $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) + [src, src_off, dst, dst_off, n] -> + outOfLinePrimop $ do + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (smallPtrArraySize platform profile src) + emitRangeBoundsCheck dst_off n (smallPtrArraySize platform profile dst) + callExternalPrimop CopySmallMutableArrayOp [src, src_off, dst, dst_off, n] + _ -> panic "CopySmallMutableArrayOp" CloneSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args CloneSmallMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args FreezeSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args ThawSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size - -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External + -> inlinePrimop $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + args -> externalPrimop primop args -- First we handle various awkward cases specially. - ParOp -> \[arg] -> opIntoRegs $ \[res] -> + ParOp -> \[arg] -> inlinePrimop $ \[res] -> -- for now, just implement this in a C function -- later, we might want to inline it. emitCCall @@ -257,7 +298,7 @@ emitPrimOp cfg primop = (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction))) [(baseExpr platform, AddrHint), (arg,AddrHint)] - SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do + SparkOp -> \[arg] -> inlinePrimop $ \[res] -> do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary. @@ -269,24 +310,24 @@ emitPrimOp cfg primop = [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) - GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do + GetCCSOfOp -> \[arg] -> inlinePrimop $ \[res] -> do let val | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg) | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val - GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> + GetCurrentCCSOp -> \[_] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (cccsExpr platform) - MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> + MyThreadIdOp -> \[] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (currentTSOExpr platform) - ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> + ReadMutVarOp -> \[mutv] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire) [ cmmOffsetW platform mutv (fixedHdrSizeW profile) ] - WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \[] -> do + WriteMutVarOp -> \[mutv, var] -> inlinePrimop $ \[] -> do old_val <- CmmLocal <$> newTemp (cmmExprType platform var) emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) @@ -299,14 +340,14 @@ emitPrimOp cfg primop = [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ] emitDirtyMutVar mutv (CmmReg old_val) - AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do + AtomicSwapMutVarOp -> \[mutv, val] -> inlinePrimop $ \[res] -> do let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile) emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val] emitDirtyMutVar mutv (CmmReg (CmmLocal res)) -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + SizeofByteArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (byteArraySize platform profile arg) -- #define sizzeofMutableByteArrayzh(r,a) \ @@ -315,37 +356,37 @@ emitPrimOp cfg primop = -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + GetSizeofMutableByteArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (byteArraySize platform profile arg) -- #define touchzh(o) /* nothing */ - TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> + TouchOp -> \args@[_] -> inlinePrimop $ \res@[] -> emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) - ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> + ByteArrayContents_Char -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) - MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> + MutableByteArrayContents_Char -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) - StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> + StableNameToIntOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) EqStablePtrOp -> opTranslate (mo_wordEq platform) - ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a - AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> + AddrToAnyOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg -- #define hvalueToAddrzh(r, a) r=(W_)a - AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> + AnyToAddrOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg {- Freezing arrays-of-ptrs requires changing an info table, for the @@ -358,45 +399,45 @@ emitPrimOp cfg primop = -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); -- r = a; -- } - UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + UnsafeFreezeArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] - UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + UnsafeFreezeSmallArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) - UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + UnsafeFreezeByteArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg -- #define unsafeThawByteArrayzh(r,a) r=(a) - UnsafeThawByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + UnsafeThawByteArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg -- Reading/writing pointer arrays - ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + ReadArrayOp -> \[obj, ix] -> inlinePrimop $ \[res] -> doReadPtrArrayOp res obj ix - IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + IndexArrayOp -> \[obj, ix] -> inlinePrimop $ \[res] -> doReadPtrArrayOp res obj ix - WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> + WriteArrayOp -> \[obj, ix, v] -> inlinePrimop $ \[] -> doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + ReadSmallArrayOp -> \[obj, ix] -> inlinePrimop $ \[res] -> doReadSmallPtrArrayOp res obj ix - IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + IndexSmallArrayOp -> \[obj, ix] -> inlinePrimop $ \[res] -> doReadSmallPtrArrayOp res obj ix - WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> + WriteSmallArrayOp -> \[obj,ix,v] -> inlinePrimop $ \[] -> doWriteSmallPtrArrayOp obj ix v -- Getting the size of pointer arrays - SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + SizeofArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (ptrArraySize platform profile arg) SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp - SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + SizeofSmallArrayOp -> \[arg] -> inlinePrimop $ \[res] -> emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg) SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp @@ -404,550 +445,550 @@ emitPrimOp cfg primop = -- IndexXXXoffAddr - IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Char -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_WideChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Int -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Addr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Float -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing f32 res args - IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Double -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing f64 res args - IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_StablePtr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Int8 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b8 res args - IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Int16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b16 res args - IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Int32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b32 res args - IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Int64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b64 res args - IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b8 res args - IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b16 res args - IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b32 res args - IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Char -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_WideChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Int -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Addr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Float -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing f32 res args - ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Double -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing f64 res args - ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_StablePtr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Int8 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b8 res args - ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Int16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b16 res args - ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Int32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b32 res args - ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Int64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b64 res args - ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b8 res args - ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b16 res args - ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b32 res args - ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOp Nothing b64 res args -- IndexWord8OffAddrAsXXX - IndexOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - IndexOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - IndexOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - IndexOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - IndexOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - IndexOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing f32 b8 res args - IndexOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing f64 b8 res args - IndexOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - IndexOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b16 b8 res args - IndexOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b32 b8 res args - IndexOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b64 b8 res args - IndexOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b16 b8 res args - IndexOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b32 b8 res args - IndexOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + IndexOffAddrOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b64 b8 res args -- ReadWord8OffAddrAsXXX, identical to IndexWord8OffAddrAsXXX - ReadOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - ReadOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - ReadOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - ReadOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - ReadOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - ReadOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing f32 b8 res args - ReadOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing f64 b8 res args - ReadOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing (bWord platform) b8 res args - ReadOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b16 b8 res args - ReadOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b32 b8 res args - ReadOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b64 b8 res args - ReadOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b16 b8 res args - ReadOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b32 b8 res args - ReadOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + ReadOffAddrOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doIndexOffAddrOpAs Nothing b64 b8 res args -- WriteWord8ArrayAsXXX - WriteOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args - WriteOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b8 res args - WriteOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args -- IndexXXXArray - IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Char -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_WideChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Int -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Addr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Float -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing f32 res args - IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Double -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing f64 res args - IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_StablePtr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Int8 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b8 res args - IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Int16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b16 res args - IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Int32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b32 res args - IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Int64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b64 res args - IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b8 res args - IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b16 res args - IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b32 res args - IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. - ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Char -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_WideChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Int -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Addr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Float -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing f32 res args - ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Double -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing f64 res args - ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_StablePtr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Int8 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b8 res args - ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Int16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b16 res args - ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Int32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b32 res args - ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Int64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b64 res args - ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b8 res args - ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b16 res args - ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b32 res args - ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOp Nothing b64 res args -- IndexWord8ArrayAsXXX - IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args - IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args - IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b16 b8 res args - IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b32 b8 res args - IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args - IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b16 b8 res args - IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b32 b8 res args - IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + IndexByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX - ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args - ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args - ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b16 b8 res args - ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b32 b8 res args - ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args - ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b16 b8 res args - ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b32 b8 res args - ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + ReadByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- WriteXXXoffAddr - WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Char -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args - WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_WideChar -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args - WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Int -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Addr -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Float -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing f32 res args - WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Double -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing f64 res args - WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_StablePtr -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Int8 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Int16 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b16 res args - WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Int32 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b32 res args - WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Int64 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b64 res args - WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word8 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b8 res args - WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word16 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b16 res args - WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word32 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b32 res args - WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + WriteOffAddrOp_Word64 -> \args -> inlinePrimop $ \res -> doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray - WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Char -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_WideChar -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args - WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Int -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Addr -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Float -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing f32 res args - WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Double -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing f64 res args - WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_StablePtr -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Int8 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Int16 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b16 res args - WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Int32 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b32 res args - WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Int64 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b64 res args - WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word16 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b16 res args - WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word32 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b32 res args - WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word64 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b64 res args -- WriteInt8ArrayAsXXX - WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsChar -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsWideChar -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args - WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsInt -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsWord -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsAddr -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsFloat -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsDouble -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsStablePtr -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsInt16 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsInt32 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsInt64 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsWord16 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsWord32 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + WriteByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res -> doWriteByteArrayOp Nothing b8 res args -- Copying and setting byte arrays - CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] -> doCopyByteArrayOp src src_off dst dst_off n - CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] -> doCopyMutableByteArrayOp src src_off dst dst_off n - CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] -> doCopyMutableByteArrayNonOverlappingOp src src_off dst dst_off n - CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> + CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> inlinePrimop $ \[] -> doCopyByteArrayToAddrOp src src_off dst n - CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> + CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> inlinePrimop $ \[] -> doCopyMutableByteArrayToAddrOp src src_off dst n - CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> + CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> inlinePrimop $ \[] -> doCopyAddrToByteArrayOp src dst dst_off n - CopyAddrToAddrOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + CopyAddrToAddrOp -> \[src,dst,n] -> inlinePrimop $ \[] -> doCopyAddrToAddrOp src dst n - CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> inlinePrimop $ \[] -> doCopyAddrToAddrNonOverlappingOp src dst n - SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> + SetByteArrayOp -> \[ba,off,len,c] -> inlinePrimop $ \[] -> doSetByteArrayOp ba off len c - SetAddrRangeOp -> \[dst,len,c] -> opIntoRegs $ \[] -> + SetAddrRangeOp -> \[dst,len,c] -> inlinePrimop $ \[] -> doSetAddrRangeOp dst len c -- Comparing byte arrays - CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> + CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> inlinePrimop $ \[res] -> doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n - BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> + BSwap16Op -> \[w] -> inlinePrimop $ \[res] -> emitBSwapCall res w W16 - BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> + BSwap32Op -> \[w] -> inlinePrimop $ \[res] -> emitBSwapCall res w W32 - BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> + BSwap64Op -> \[w] -> inlinePrimop $ \[res] -> emitBSwapCall res w W64 - BSwapOp -> \[w] -> opIntoRegs $ \[res] -> + BSwapOp -> \[w] -> inlinePrimop $ \[res] -> emitBSwapCall res w (wordWidth platform) - BRev8Op -> \[w] -> opIntoRegs $ \[res] -> + BRev8Op -> \[w] -> inlinePrimop $ \[res] -> emitBRevCall res w W8 - BRev16Op -> \[w] -> opIntoRegs $ \[res] -> + BRev16Op -> \[w] -> inlinePrimop $ \[res] -> emitBRevCall res w W16 - BRev32Op -> \[w] -> opIntoRegs $ \[res] -> + BRev32Op -> \[w] -> inlinePrimop $ \[res] -> emitBRevCall res w W32 - BRev64Op -> \[w] -> opIntoRegs $ \[res] -> + BRev64Op -> \[w] -> inlinePrimop $ \[res] -> emitBRevCall res w W64 - BRevOp -> \[w] -> opIntoRegs $ \[res] -> + BRevOp -> \[w] -> inlinePrimop $ \[res] -> emitBRevCall res w (wordWidth platform) -- Population count - PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> + PopCnt8Op -> \[w] -> inlinePrimop $ \[res] -> emitPopCntCall res w W8 - PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> + PopCnt16Op -> \[w] -> inlinePrimop $ \[res] -> emitPopCntCall res w W16 - PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> + PopCnt32Op -> \[w] -> inlinePrimop $ \[res] -> emitPopCntCall res w W32 - PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> + PopCnt64Op -> \[w] -> inlinePrimop $ \[res] -> emitPopCntCall res w W64 - PopCntOp -> \[w] -> opIntoRegs $ \[res] -> + PopCntOp -> \[w] -> inlinePrimop $ \[res] -> emitPopCntCall res w (wordWidth platform) -- Parallel bit deposit - Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pdep8Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPdepCall res src mask W8 - Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pdep16Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPdepCall res src mask W16 - Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pdep32Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPdepCall res src mask W32 - Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pdep64Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPdepCall res src mask W64 - PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> + PdepOp -> \[src, mask] -> inlinePrimop $ \[res] -> emitPdepCall res src mask (wordWidth platform) -- Parallel bit extract - Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pext8Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPextCall res src mask W8 - Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pext16Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPextCall res src mask W16 - Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pext32Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPextCall res src mask W32 - Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> + Pext64Op -> \[src, mask] -> inlinePrimop $ \[res] -> emitPextCall res src mask W64 - PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> + PextOp -> \[src, mask] -> inlinePrimop $ \[res] -> emitPextCall res src mask (wordWidth platform) -- count leading zeros - Clz8Op -> \[w] -> opIntoRegs $ \[res] -> + Clz8Op -> \[w] -> inlinePrimop $ \[res] -> emitClzCall res w W8 - Clz16Op -> \[w] -> opIntoRegs $ \[res] -> + Clz16Op -> \[w] -> inlinePrimop $ \[res] -> emitClzCall res w W16 - Clz32Op -> \[w] -> opIntoRegs $ \[res] -> + Clz32Op -> \[w] -> inlinePrimop $ \[res] -> emitClzCall res w W32 - Clz64Op -> \[w] -> opIntoRegs $ \[res] -> + Clz64Op -> \[w] -> inlinePrimop $ \[res] -> emitClzCall res w W64 - ClzOp -> \[w] -> opIntoRegs $ \[res] -> + ClzOp -> \[w] -> inlinePrimop $ \[res] -> emitClzCall res w (wordWidth platform) -- count trailing zeros - Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> + Ctz8Op -> \[w] -> inlinePrimop $ \[res] -> emitCtzCall res w W8 - Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> + Ctz16Op -> \[w] -> inlinePrimop $ \[res] -> emitCtzCall res w W16 - Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> + Ctz32Op -> \[w] -> inlinePrimop $ \[res] -> emitCtzCall res w W32 - Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> + Ctz64Op -> \[w] -> inlinePrimop $ \[res] -> emitCtzCall res w W64 - CtzOp -> \[w] -> opIntoRegs $ \[res] -> + CtzOp -> \[w] -> inlinePrimop $ \[res] -> emitCtzCall res w (wordWidth platform) -- Unsigned int to floating point conversions - WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> + WordToFloatOp -> \[w] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_UF_Conv W32) [w] - WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> + WordToDoubleOp -> \[w] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_UF_Conv W64) [w] -- Atomic operations - InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] -> + InterlockedExchange_Addr -> \[src, value] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] - InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] -> + InterlockedExchange_Word -> \[src, value] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] - FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchAddAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_Add addr (bWord platform) n - FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchSubAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_Sub addr (bWord platform) n - FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchAndAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_And addr (bWord platform) n - FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchNandAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_Nand addr (bWord platform) n - FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchOrAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_Or addr (bWord platform) n - FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + FetchXorAddrOp_Word -> \[addr, n] -> inlinePrimop $ \[res] -> doAtomicAddrRMW res AMO_Xor addr (bWord platform) n - AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] -> + AtomicReadAddrOp_Word -> \[addr] -> inlinePrimop $ \[res] -> doAtomicReadAddr res addr (bWord platform) - AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] -> + AtomicWriteAddrOp_Word -> \[addr, val] -> inlinePrimop $ \[] -> doAtomicWriteAddr addr (bWord platform) val - CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Addr -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] - CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Word -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] - CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Word8 -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new] - CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Word16 -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new] - CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Word32 -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new] - CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + CasAddrOp_Word64 -> \[dst, expected, new] -> inlinePrimop $ \[res] -> emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new] -- SIMD primops - (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do + (VecBroadcastOp vcat n w) -> \[e] -> inlinePrimop $ \[res] -> do checkVecCompatibility cfg vcat n w doVecBroadcastOp ty e res where @@ -955,7 +996,7 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmType vcat n w - (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do + (VecPackOp vcat n w) -> \es -> inlinePrimop $ \[res] -> do checkVecCompatibility cfg vcat n w when (es `lengthIsNot` n) $ panic "emitPrimOp: VecPackOp has wrong number of arguments" @@ -964,7 +1005,7 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmType vcat n w - (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do + (VecUnpackOp vcat n w) -> \[arg] -> inlinePrimop $ \res -> do checkVecCompatibility cfg vcat n w when (res `lengthIsNot` n) $ panic "emitPrimOp: VecUnpackOp has wrong number of results" @@ -973,56 +1014,56 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmType vcat n w - (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do + (VecInsertOp vcat n w) -> \[v,e,i] -> inlinePrimop $ \[res] -> do checkVecCompatibility cfg vcat n w doVecInsertOp ty v e i res where ty :: CmmType ty = vecCmmType vcat n w - (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecIndexByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecReadByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecWriteByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecIndexOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecReadOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecWriteOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecCmmType vcat n w - (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecIndexScalarByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where @@ -1032,7 +1073,7 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmCat vcat w - (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecReadScalarByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where @@ -1042,14 +1083,14 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmCat vcat w - (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecWriteScalarByteArrayOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmCat vcat w - (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecIndexScalarOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where @@ -1059,7 +1100,7 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmCat vcat w - (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecReadScalarOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where @@ -1069,79 +1110,79 @@ emitPrimOp cfg primop = ty :: CmmType ty = vecCmmCat vcat w - (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + (VecWriteScalarOffAddrOp vcat n w) -> \args -> inlinePrimop $ \res0 -> do checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecCmmCat vcat w - VecShuffleOp vcat n w -> \ args -> opIntoRegs $ \ [res] -> do + VecShuffleOp vcat n w -> \ args -> inlinePrimop $ \ [res] -> do checkVecCompatibility cfg vcat n w doShuffleOp (vecCmmType vcat n w) args res -- Prefetch - PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> + PrefetchByteArrayOp3 -> \args -> inlinePrimop $ \[] -> doPrefetchByteArrayOp 3 args - PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> + PrefetchMutableByteArrayOp3 -> \args -> inlinePrimop $ \[] -> doPrefetchMutableByteArrayOp 3 args - PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> + PrefetchAddrOp3 -> \args -> inlinePrimop $ \[] -> doPrefetchAddrOp 3 args - PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> + PrefetchValueOp3 -> \args -> inlinePrimop $ \[] -> doPrefetchValueOp 3 args - PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> + PrefetchByteArrayOp2 -> \args -> inlinePrimop $ \[] -> doPrefetchByteArrayOp 2 args - PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> + PrefetchMutableByteArrayOp2 -> \args -> inlinePrimop $ \[] -> doPrefetchMutableByteArrayOp 2 args - PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> + PrefetchAddrOp2 -> \args -> inlinePrimop $ \[] -> doPrefetchAddrOp 2 args - PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> + PrefetchValueOp2 -> \args -> inlinePrimop $ \[] -> doPrefetchValueOp 2 args - PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> + PrefetchByteArrayOp1 -> \args -> inlinePrimop $ \[] -> doPrefetchByteArrayOp 1 args - PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> + PrefetchMutableByteArrayOp1 -> \args -> inlinePrimop $ \[] -> doPrefetchMutableByteArrayOp 1 args - PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> + PrefetchAddrOp1 -> \args -> inlinePrimop $ \[] -> doPrefetchAddrOp 1 args - PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> + PrefetchValueOp1 -> \args -> inlinePrimop $ \[] -> doPrefetchValueOp 1 args - PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> + PrefetchByteArrayOp0 -> \args -> inlinePrimop $ \[] -> doPrefetchByteArrayOp 0 args - PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> + PrefetchMutableByteArrayOp0 -> \args -> inlinePrimop $ \[] -> doPrefetchMutableByteArrayOp 0 args - PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> + PrefetchAddrOp0 -> \args -> inlinePrimop $ \[] -> doPrefetchAddrOp 0 args - PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> + PrefetchValueOp0 -> \args -> inlinePrimop $ \[] -> doPrefetchValueOp 0 args -- Atomic read-modify-write - FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchAddByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n - FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchSubByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n - FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchAndByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n - FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchNandByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n - FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchOrByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n - FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + FetchXorByteArrayOp_Int -> \[mba, ix, n] -> inlinePrimop $ \[res] -> doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n - AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> + AtomicReadByteArrayOp_Int -> \[mba, ix] -> inlinePrimop $ \[res] -> doAtomicReadByteArray res mba ix (bWord platform) - AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> + AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> inlinePrimop $ \[] -> doAtomicWriteByteArray mba ix (bWord platform) val - CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + CasByteArrayOp_Int -> \[mba, ix, old, new] -> inlinePrimop $ \[res] -> doCasByteArray res mba ix (bWord platform) old new - CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> inlinePrimop $ \[res] -> doCasByteArray res mba ix b8 old new - CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> inlinePrimop $ \[res] -> doCasByteArray res mba ix b16 old new - CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> inlinePrimop $ \[res] -> doCasByteArray res mba ix b32 old new - CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> inlinePrimop $ \[res] -> doCasByteArray res mba ix b64 old new -- The rest just translate straightforwardly @@ -1671,7 +1712,7 @@ emitPrimOp cfg primop = -- tagToEnum# is special: we need to pull the constructor -- out of the table, and perform an appropriate return. - TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do + TagToEnumOp -> \[amode] -> PrimopCmmEmit True $ \res_ty -> do -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because -- you used tagToEnum# in a non-monomorphic setting, e.g., @@ -1680,7 +1721,7 @@ emitPrimOp cfg primop = let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty) massert (isEnumerationTyCon tycon) platform <- getPlatform - pure [tagToClosure platform tycon amode] + emitReturn [tagToClosure platform tycon amode] -- Out of line primops. -- TODO compiler need not know about these @@ -1791,24 +1832,24 @@ emitPrimOp cfg primop = result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit - opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg + opNop args = inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg where [arg] = args opNarrow :: [CmmExpr] -> (Width -> Width -> MachOp, Width) -> PrimopCmmEmit - opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $ + opNarrow args (mop, rep) = inlinePrimop $ \[res] -> emitAssign (CmmLocal res) $ CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]] where [arg] = args -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. opCallish :: CallishMachOp -> [CmmExpr] -> PrimopCmmEmit - opCallish prim args = opIntoRegs $ \[res] -> emitPrimCall [res] prim args + opCallish prim args = inlinePrimop $ \[res] -> emitPrimCall [res] prim args opTranslate :: MachOp -> [CmmExpr] -> PrimopCmmEmit - opTranslate mop args = opIntoRegs $ \[res] -> do + opTranslate mop args = inlinePrimop $ \[res] -> do let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) emit stmt @@ -1830,28 +1871,36 @@ emitPrimOp cfg primop = :: Either CallishMachOp GenericOp -> [CmmExpr] -> PrimopCmmEmit - opCallishHandledLater callOrNot args = opIntoRegs $ \res0 -> case callOrNot of + opCallishHandledLater callOrNot args = inlinePrimop $ \res0 -> case callOrNot of Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args Right gen -> gen res0 args - opIntoRegs - :: ([LocalReg] -- where to put the results + inlinePrimopWithReturnType + :: (Type -- return type + -> [LocalReg] -- where to put the results -> FCode ()) -> PrimopCmmEmit - opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do - regs <- case result_info of - ReturnsVoid -> pure [] - ReturnsPrim rep - -> do reg <- newTemp (primRepCmmType platform rep) - pure [reg] - - ReturnsTuple - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty - pure regs - f regs - pure $ map (CmmReg . CmmLocal) regs - - alwaysExternal = \_ -> PrimopCmmEmit_External + inlinePrimopWithReturnType f = PrimopCmmEmit + { primopCmmInline = True + , primopCmmCode = \res_ty -> do + regs <- case result_info of + ReturnsVoid -> pure [] + ReturnsPrim rep + -> do reg <- newTemp (primRepCmmType platform rep) + pure [reg] + + ReturnsTuple + -> do (regs, _hints) <- newUnboxedTupleRegs res_ty + pure regs + f res_ty regs + emitReturn (map (CmmReg . CmmLocal) regs) + } + + inlinePrimop :: ([LocalReg] -> FCode ()) -> PrimopCmmEmit + inlinePrimop f = inlinePrimopWithReturnType (const f) + + alwaysExternal = externalPrimop primop + -- Note [QuotRem optimization] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops @@ -1898,7 +1947,7 @@ emitPrimOp cfg primop = = case signs of -- For fused multiply-add x * y + z, we fall back to the C implementation. - FMAdd -> opIntoRegs $ \ [res] -> fmaCCall w res arg_x arg_y arg_z + FMAdd -> inlinePrimop $ \ [res] -> fmaCCall w res arg_x arg_y arg_z -- Other fused multiply-add operations are implemented in terms of fmadd -- This is sound: it does not lose any precision. @@ -1913,13 +1962,17 @@ emitPrimOp cfg primop = = CmmMachOp (MO_VF_Neg l w) [x] fmaOp _ _ _ _ = panic "fmaOp: wrong number of arguments (expected 3)" -data PrimopCmmEmit - -- | Out of line fake primop that's actually just a foreign call to other - -- (presumably) C--. - = PrimopCmmEmit_External - -- | Real primop turned into inline C--. - | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it - -> FCode [CmmExpr]) -- just for TagToEnum for now +data PrimopCmmEmit = PrimopCmmEmit + { primopCmmInline :: !Bool + -- ^ Is the primop code fully inline + -- See Note [Inlining out-of-line primops and heap checks] + -- in GHC.StgToCmm.Expr + , primopCmmCode :: Type -> FCode ReturnKind + -- ^ Code for the primop. + -- May call external C-- functions if inline=false above. + -- The return type is passed, some primops are specialized to it (just + -- TagToEnum for now) + } type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1264,8 +1264,10 @@ tcHsType _ rn_ty@(HsStarTy _ _) exp_kind = checkExpKind rn_ty liftedTypeKind liftedTypeKind exp_kind --------- Literals -tcHsType _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon naturalTyCon +tcHsType _ rn_ty@(HsTyLit _ (HsNumTy x n)) exp_kind + = do { when (n < 0) $ + addErr $ TcRnNegativeNumTypeLiteral (HsNumTy x n) + ; checkWiredInTyCon naturalTyCon ; checkExpKind rn_ty (mkNumLitTy n) naturalTy exp_kind } tcHsType _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind ===================================== testsuite/tests/codeGen/should_fail/T26958.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Main where +import GHC.Exts +import GHC.IO (IO(..)) + +-- Test that -fcheck-prim-bounds catches OOB access in copySmallArray# +-- when the length argument is a non-literal (variable). See #26958. +main :: IO () +main = IO $ \s0 -> + case newSmallArray# 1# () s0 of { (# s1, srcm #) -> + case unsafeFreezeSmallArray# srcm s1 of { (# s2, src #) -> + case sizeofSmallArray# src of { n# -> + case newSmallArray# 1# () s2 of { (# s3, dst #) -> + case copySmallArray# src 0# dst 5# n# s3 of + s4 -> (# s4, () #) }}}} ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,3 +24,4 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') +check_bounds_test('T26958') ===================================== testsuite/tests/parser/should_fail/T26860ppr_overloaded.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + +module T26860ppr_overloaded where + +-- Test that the error message containing the string literal is well-formatted. +-- See also: parser/should_fail/MultilineStringsError +x :: Int +x = "first line \ + \asdf\n\ + \second line" + ===================================== testsuite/tests/parser/should_fail/T26860ppr_overloaded.stderr ===================================== @@ -0,0 +1,14 @@ +T26860ppr_overloaded.hs:8:5: error: [GHC-39999] + • No instance for ‘GHC.Internal.Data.String.IsString Int’ + arising from the literal ‘"first line \ + \asdf\n\ + \second line"’ + • In the expression: + "first line \ + \asdf\n\ + \second line" + In an equation for ‘x’: + x = "first line \ + \asdf\n\ + \second line" + ===================================== testsuite/tests/parser/should_fail/T26860ppr_tylit.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} + +module T26860ppr_tylit where + +import Data.Kind (Type) + +-- Test that the error message containing the string literal is well-formatted. +-- See also: parser/should_fail/MultilineStringsError +type X :: Type +type X = "first line \ + \asdf\n\ + \second line" + ===================================== testsuite/tests/parser/should_fail/T26860ppr_tylit.stderr ===================================== @@ -0,0 +1,11 @@ +T26860ppr_tylit.hs:10:10: error: [GHC-83865] + • Expected a type, + but ‘"first line \ + \asdf\n\ + \second line"’ has kind + ‘GHC.Internal.Types.Symbol’ + • In the type ‘"first line \ + \asdf\n\ + \second line"’ + In the type synonym declaration for ‘X’ + ===================================== testsuite/tests/parser/should_fail/all.T ===================================== @@ -245,3 +245,5 @@ test('T26418', normal, compile_fail, ['']) test('T12488c', normal, compile_fail, ['']) test('T12488d', normal, compile_fail, ['']) test('T26860ppr', normal, compile_fail, ['']) +test('T26860ppr_overloaded', normal, compile_fail, ['']) +test('T26860ppr_tylit', normal, compile_fail, ['']) ===================================== testsuite/tests/typecheck/should_fail/T26861.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE RequiredTypeArguments #-} + +module T26861 where + +import Data.Proxy +import GHC.TypeLits + +main :: IO () +main = print (natVis (-42)) + +natVis :: forall a -> KnownNat a => Integer +natVis n = natVal (Proxy @n) ===================================== testsuite/tests/typecheck/should_fail/T26861.stderr ===================================== @@ -0,0 +1,6 @@ +T26861.hs:11:23: error: [GHC-93632] + • Illegal literal in type (type literals must not be negative): -42 + • In the type ‘-42’ + In the first argument of ‘print’, namely ‘(natVis (-42))’ + In the expression: print (natVis (-42)) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -752,3 +752,4 @@ test('T23162a', normal, compile_fail, ['']) test('T23162b', normal, compile_fail, ['']) test('T23162c', normal, compile, ['']) test('T23162d', normal, compile, ['']) +test('T26861', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c0cb966f3868b0084985152273f9e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c0cb966f3868b0084985152273f9e… You're receiving this email because of your account on gitlab.haskell.org.

1 0