Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - 6 changed files: - compiler/GHC/Core/Utils.hs - + testsuite/tests/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - + testsuite/tests/rep-poly/T26072b.hs - testsuite/tests/rep-poly/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -78,7 +78,7 @@ import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv -import GHC.Core.TyCo.Compare( eqType, eqTypeX ) +import GHC.Core.TyCo.Compare( eqType, eqTypeX, eqTypeIgnoringMultiplicity ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.TyCon @@ -275,7 +275,7 @@ mkCast expr co = assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast" <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $ - warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Bad cast" + warnPprTrace (not (coercionLKind co `eqTypeIgnoringMultiplicity` exprType expr)) "Bad cast" (vcat [ text "Coercion LHS kind does not match enclosed expression type" , text "co:" <+> ppr co , text "coercionLKind:" <+> ppr (coercionLKind co) ===================================== testsuite/tests/linear/should_run/T26311.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts ( Int# ) + +expensive :: Int -> Int# +expensive 0 = 2# +expensive i = expensive (i-1) + +data D = MkD Int# Int + +f :: a -> Bool +f _ = False +{-# NOINLINE f #-} + +{-# RULES "f/MkD" forall x. f (MkD x) = True #-} + +bar :: Bool +bar = f (MkD (expensive 10)) + +main :: IO () +main = print bar ===================================== testsuite/tests/linear/should_run/T26311.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== testsuite/tests/linear/should_run/all.T ===================================== @@ -1,2 +1,3 @@ test('LinearTypeable', normal, compile_and_run, ['']) +test('T26311', normal, compile_and_run, ['-O1']) test('LinearGhci', normal, ghci_script, ['LinearGhci.script']) ===================================== testsuite/tests/rep-poly/T26072b.hs ===================================== @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +module T26072b where + +-- base +import Data.Kind +import GHC.TypeNats +import GHC.Exts + ( TYPE, RuntimeRep(..), LiftedRep + , proxy# + ) + +-------------------------------------------------------------------------------- + +-- Stub for functions in 'primitive' (to avoid dependency) +type PrimArray :: Type -> Type +data PrimArray a = MkPrimArray + +indexPrimArray :: PrimArray a -> Int -> a +indexPrimArray _ _ = error "unimplemented" +{-# NOINLINE indexPrimArray #-} + +-------------------------------------------------------------------------------- + +int :: forall n. KnownNat n => Int +int = fromIntegral ( natVal' @n proxy# ) + +type Fin :: Nat -> Type +newtype Fin n = Fin { getFin :: Int } + +-- Vector +type V :: Nat -> Type -> Type +newtype V n a = V ( PrimArray a ) + +-- Matrix +type M :: Nat -> Type -> Type +newtype M n a = M ( PrimArray a ) + +type IndexRep :: (Type -> Type) -> RuntimeRep +type family IndexRep f +class Ix f where + type Index f :: TYPE (IndexRep f) + (!) :: f a -> Index f -> a + infixl 9 ! + +type instance IndexRep ( V n ) = LiftedRep +instance Ix ( V n ) where + type Index ( V n ) = Fin n + V v ! Fin !i = indexPrimArray v i + {-# INLINE (!) #-} + +type instance IndexRep ( M m ) = TupleRep [ LiftedRep, LiftedRep ] + +instance KnownNat n => Ix ( M n ) where + type Index ( M n ) = (# Fin n, Fin n #) + M m ! (# Fin !i, Fin !j #) = indexPrimArray m ( i + j * int @n ) + {-# INLINE (!) #-} + +rowCol :: forall n a. ( KnownNat n, Num a ) => Fin n -> M n a -> V n a -> a +rowCol i m v = go 0 ( Fin 0 ) + where + n = int @n + go :: a -> Fin n -> a + go !acc j@( Fin !j_ ) + | j_ >= n + = acc + | otherwise + = go ( acc + m ! (# i , j #) * v ! j ) ( Fin ( j_ + 1 ) ) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -127,6 +127,7 @@ test('T17536b', normal, compile, ['']) ## test('T21650_a', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T21650_b', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T26072', js_broken(26578), compile, ['']) ## +test('T26072b', js_broken(26578), compile, ['']) ## test('RepPolyArgument2', normal, compile, ['']) ## test('RepPolyCase2', js_broken(26578), compile, ['']) ## test('RepPolyRule3', normal, compile, ['']) ## View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c12fa73e643e2df4428454e21375001... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c12fa73e643e2df4428454e21375001... You're receiving this email because of your account on gitlab.haskell.org.