Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -78,7 +78,7 @@ import GHC.Core.Type as Type
    78 78 
     import GHC.Core.Predicate( isEqPred )
    79 79 
     import GHC.Core.Predicate( isUnaryClass )
    80 80 
     import GHC.Core.FamInstEnv
    81 
    -import GHC.Core.TyCo.Compare( eqType, eqTypeX )
    81 
    +import GHC.Core.TyCo.Compare( eqType, eqTypeX, eqTypeIgnoringMultiplicity )
    82 82 
     import GHC.Core.Coercion
    83 83 
     import GHC.Core.Reduction
    84 84 
     import GHC.Core.TyCon
    ... ... @@ -275,7 +275,7 @@ mkCast expr co
    275 275 
       = assertPpr (coercionRole co == Representational)
    276 276 
                   (text "coercion" <+> ppr co <+> text "passed to mkCast"
    277 277 
                    <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $
    278 
    -    warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Bad cast"
    278 
    +    warnPprTrace (not (coercionLKind co `eqTypeIgnoringMultiplicity` exprType expr)) "Bad cast"
    279 279 
           (vcat [ text "Coercion LHS kind does not match enclosed expression type"
    280 280 
                 , text "co:" <+> ppr co
    281 281 
                 , text "coercionLKind:" <+> ppr (coercionLKind co)

  • testsuite/tests/linear/should_run/T26311.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +
    3 
    +module Main where
    4 
    +
    5 
    +import GHC.Exts ( Int# )
    6 
    +
    7 
    +expensive :: Int -> Int#
    8 
    +expensive 0 = 2#
    9 
    +expensive i = expensive (i-1)
    10 
    +
    11 
    +data D = MkD Int# Int
    12 
    +
    13 
    +f :: a -> Bool
    14 
    +f _ = False
    15 
    +{-# NOINLINE f #-}
    16 
    +
    17 
    +{-# RULES "f/MkD" forall x. f (MkD x) = True #-}
    18 
    +
    19 
    +bar :: Bool
    20 
    +bar = f (MkD (expensive 10))
    21 
    +
    22 
    +main :: IO ()
    23 
    +main = print bar

  • testsuite/tests/linear/should_run/T26311.stdout
    1 
    +True

  • testsuite/tests/linear/should_run/all.T
    1 1 
     test('LinearTypeable', normal, compile_and_run, [''])
    2 
    +test('T26311', normal, compile_and_run, ['-O1'])
    2 3 
     test('LinearGhci', normal, ghci_script, ['LinearGhci.script'])

  • testsuite/tests/rep-poly/T26072b.hs
    1 
    +{-# LANGUAGE AllowAmbiguousTypes #-}
    2 
    +{-# LANGUAGE BangPatterns #-}
    3 
    +{-# LANGUAGE BlockArguments #-}
    4 
    +{-# LANGUAGE DataKinds #-}
    5 
    +{-# LANGUAGE MagicHash #-}
    6 
    +{-# LANGUAGE PolyKinds #-}
    7 
    +{-# LANGUAGE ScopedTypeVariables #-}
    8 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    9 
    +{-# LANGUAGE TypeApplications #-}
    10 
    +{-# LANGUAGE TypeFamilies #-}
    11 
    +{-# LANGUAGE UnboxedTuples #-}
    12 
    +
    13 
    +module T26072b where
    14 
    +
    15 
    +-- base
    16 
    +import Data.Kind
    17 
    +import GHC.TypeNats
    18 
    +import GHC.Exts
    19 
    +  ( TYPE, RuntimeRep(..), LiftedRep
    20 
    +  , proxy#
    21 
    +  )
    22 
    +
    23 
    +--------------------------------------------------------------------------------
    24 
    +
    25 
    +-- Stub for functions in 'primitive' (to avoid dependency)
    26 
    +type PrimArray :: Type -> Type
    27 
    +data PrimArray a = MkPrimArray
    28 
    +
    29 
    +indexPrimArray :: PrimArray a -> Int -> a
    30 
    +indexPrimArray _ _ = error "unimplemented"
    31 
    +{-# NOINLINE indexPrimArray #-}
    32 
    +
    33 
    +--------------------------------------------------------------------------------
    34 
    +
    35 
    +int :: forall n. KnownNat n => Int
    36 
    +int = fromIntegral ( natVal' @n proxy# )
    37 
    +
    38 
    +type Fin :: Nat -> Type
    39 
    +newtype Fin n = Fin { getFin :: Int }
    40 
    +
    41 
    +-- Vector
    42 
    +type V :: Nat -> Type -> Type
    43 
    +newtype V n a = V ( PrimArray a )
    44 
    +
    45 
    +-- Matrix
    46 
    +type M :: Nat -> Type -> Type
    47 
    +newtype M n a = M ( PrimArray a )
    48 
    +
    49 
    +type IndexRep :: (Type -> Type) -> RuntimeRep
    50 
    +type family IndexRep f
    51 
    +class Ix f where
    52 
    +  type Index f :: TYPE (IndexRep f)
    53 
    +  (!) :: f a -> Index f -> a
    54 
    +  infixl 9 !
    55 
    +
    56 
    +type instance IndexRep ( V n ) = LiftedRep
    57 
    +instance Ix ( V n ) where
    58 
    +  type Index ( V n ) = Fin n
    59 
    +  V v ! Fin !i = indexPrimArray v i
    60 
    +  {-# INLINE (!) #-}
    61 
    +
    62 
    +type instance IndexRep ( M m ) = TupleRep [ LiftedRep, LiftedRep ]
    63 
    +
    64 
    +instance KnownNat n => Ix ( M n ) where
    65 
    +  type Index ( M n ) = (# Fin n, Fin n #)
    66 
    +  M m ! (# Fin !i, Fin !j #) = indexPrimArray m ( i + j * int @n )
    67 
    +  {-# INLINE (!) #-}
    68 
    +
    69 
    +rowCol :: forall n a. ( KnownNat n, Num a ) => Fin n -> M n a -> V n a -> a
    70 
    +rowCol i m v = go 0 ( Fin 0 )
    71 
    +  where
    72 
    +    n = int @n
    73 
    +    go :: a -> Fin n -> a
    74 
    +    go !acc j@( Fin !j_ )
    75 
    +      | j_ >= n
    76 
    +      = acc
    77 
    +      | otherwise
    78 
    +      = go ( acc + m ! (# i , j #) * v ! j ) ( Fin ( j_ + 1 ) )

  • testsuite/tests/rep-poly/all.T
    ... ... @@ -127,6 +127,7 @@ test('T17536b', normal, compile, ['']) ##
    127 127 
     test('T21650_a', js_broken(26578), compile, ['-Wno-deprecated-flags'])       ##
    128 128 
     test('T21650_b', js_broken(26578), compile, ['-Wno-deprecated-flags'])       ##
    129 129 
     test('T26072', js_broken(26578), compile, [''])                              ##
    130 
    +test('T26072b', js_broken(26578), compile, [''])                             ##
    130 131 
     test('RepPolyArgument2', normal, compile, [''])                              ##
    131 132 
     test('RepPolyCase2', js_broken(26578), compile, [''])                        ##
    132 133 
     test('RepPolyRule3', normal, compile, [''])                                  ##

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help