- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/supersven/fix-foundation-test-shift-amounts] foundation test: Fix shift amount (#26248)
by Sven Tennie (＠supersven) 27 Aug '25

27 Aug '25

Sven Tennie pushed to branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC Commits: 9ed60877 by Sven Tennie at 2025-08-27T19:06:18+02:00 foundation test: Fix shift amount (#26248) Shift primops' results are only defined for shift amounts of 0 to word size - 1. This has been partly vipe coded: https://github.com/supersven/ghc/pull/1 - - - - - 3 changed files: - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -24,7 +24,7 @@ module Main ( main ) where -import Data.Bits (Bits((.&.), bit)) +import Data.Bits (Bits((.&.), bit), finiteBitSize) import Data.Word import Data.Int import GHC.Natural @@ -133,6 +133,52 @@ newtype NonZero a = NonZero { getNonZero :: a } instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where arbitrary = nonZero +-- | A newtype for shift amounts that are bounded by word size +newtype BoundedShift a = BoundedShift { getBoundedShift :: Int } + deriving (Eq,Ord,Show) + +-- | Generate shift amounts bounded by the word size for each type +boundedShift8 :: Gen (BoundedShift Int8) +boundedShift8 = do + x <- arbitrary + return $ BoundedShift (abs x `mod` 8) + +boundedShift16 :: Gen (BoundedShift Int16) +boundedShift16 = do + x <- arbitrary + return $ BoundedShift (abs x `mod` 16) + +boundedShift32 :: Gen (BoundedShift Int32) +boundedShift32 = do + x <- arbitrary + return $ BoundedShift (abs x `mod` 32) + +boundedShift64 :: Gen (BoundedShift Int64) +boundedShift64 = do + x <- arbitrary + return $ BoundedShift (abs x `mod` 64) + +boundedShiftWord :: Gen (BoundedShift Int) +boundedShiftWord = do + x <- arbitrary + return $ BoundedShift (abs x `mod` finiteBitSize (undefined :: Word)) + +-- Arbitrary instances for BoundedShift types to work with lambda patterns +instance Arbitrary (BoundedShift Int8) where + arbitrary = boundedShift8 + +instance Arbitrary (BoundedShift Int16) where + arbitrary = boundedShift16 + +instance Arbitrary (BoundedShift Int32) where + arbitrary = boundedShift32 + +instance Arbitrary (BoundedShift Int64) where + arbitrary = boundedShift64 + +instance Arbitrary (BoundedShift Int) where + arbitrary = boundedShiftWord + instance Arbitrary Natural where arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64 @@ -395,6 +441,10 @@ class TestPrimop f where testPrimopDivLike :: String -> f -> f -> Test testPrimopDivLike _ _ _ = error "Div testing not supported for this type." + -- | Special test method for shift operations that bounds the shift amount + testPrimopShift :: String -> f -> f -> Test + testPrimopShift _ _ _ = error "Shift testing not supported for this type." + {- instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2) @@ -460,9 +510,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8# , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8# , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8# - , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# - , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# - , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# + , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# + , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# + , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8# , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8# , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8# @@ -482,8 +532,8 @@ testPrimops = Group "primop" , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8# , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8# , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8# - , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# - , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# + , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# + , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8# , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8# , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8# @@ -500,9 +550,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16# , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16# , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16# - , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# - , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# - , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# + , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# + , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# + , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16# , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16# , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16# @@ -522,8 +572,8 @@ testPrimops = Group "primop" , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16# , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16# , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16# - , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# - , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# + , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# + , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16# , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16# , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16# @@ -540,9 +590,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32# , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32# , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32# - , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# - , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# - , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# + , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# + , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# + , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32# , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32# , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32# @@ -562,8 +612,8 @@ testPrimops = Group "primop" , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32# , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32# , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32# - , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# - , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# + , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# + , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32# , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32# , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32# @@ -579,9 +629,9 @@ testPrimops = Group "primop" , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64# , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64# , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64# - , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# - , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# - , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# + , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# + , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# + , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64# , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64# , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64# @@ -600,8 +650,8 @@ testPrimops = Group "primop" , testPrimop "or64#" Primop.or64# Wrapper.or64# , testPrimop "xor64#" Primop.xor64# Wrapper.xor64# , testPrimop "not64#" Primop.not64# Wrapper.not64# - , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# - , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# + , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# + , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64# , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64# , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64# @@ -632,9 +682,9 @@ testPrimops = Group "primop" , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#) , testPrimop "chr#" Primop.chr# Wrapper.chr# , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word# - , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# - , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# - , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# + , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# + , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# + , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord# , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC# , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC# @@ -649,8 +699,8 @@ testPrimops = Group "primop" , testPrimop "or#" Primop.or# Wrapper.or# , testPrimop "xor#" Primop.xor# Wrapper.xor# , testPrimop "not#" Primop.not# Wrapper.not# - , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# - , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# + , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# + , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int# , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord# , testPrimop "geWord#" Primop.geWord# Wrapper.geWord# @@ -709,6 +759,7 @@ instance TestPrimop (Char# -> Int#) where instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShift shift :: BoundedShift Int) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) @@ -741,6 +792,7 @@ instance TestPrimop (Int# -> Word#) where instance TestPrimop (Int16# -> Int# -> Int16#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift)) instance TestPrimop (Int16# -> Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -765,6 +817,7 @@ instance TestPrimop (Int16# -> Word16#) where instance TestPrimop (Int32# -> Int# -> Int32#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift)) instance TestPrimop (Int32# -> Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -789,6 +842,7 @@ instance TestPrimop (Int32# -> Word32#) where instance TestPrimop (Int64# -> Int# -> Int64#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift)) instance TestPrimop (Int64# -> Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -809,6 +863,7 @@ instance TestPrimop (Int64# -> Word64#) where instance TestPrimop (Int8# -> Int# -> Int8#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift)) instance TestPrimop (Int8# -> Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -833,6 +888,7 @@ instance TestPrimop (Int8# -> Word8#) where instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShift shift :: BoundedShift Int) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift)) instance TestPrimop (Word# -> Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -870,6 +926,7 @@ instance TestPrimop (Word# -> Word8#) where instance TestPrimop (Word16# -> Int# -> Word16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift)) instance TestPrimop (Word16# -> Word16# -> Int#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -894,6 +951,7 @@ instance TestPrimop (Word16# -> Word16#) where instance TestPrimop (Word32# -> Int# -> Word32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift)) instance TestPrimop (Word32# -> Word32# -> Int#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -918,6 +976,7 @@ instance TestPrimop (Word32# -> Word32#) where instance TestPrimop (Word64# -> Int# -> Word64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift)) instance TestPrimop (Word64# -> Word64# -> Int#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -938,6 +997,7 @@ instance TestPrimop (Word64# -> Word64#) where instance TestPrimop (Word8# -> Int# -> Word8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift)) instance TestPrimop (Word8# -> Word8# -> Int#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) ===================================== utils/genprimopcode/Main.hs ===================================== @@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries) mkInstances inst_ty = let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" + shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShift shift :: BoundedShift " ++ shiftBoundType (head arg_tys) ++ ") -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r" in unlines $ [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where" , " testPrimop s l r = Property s $ " ++ test_lambda ] ++ (if mb_divable_tys then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda] else []) + ++ (if mb_shiftable_tys + then [" testPrimopShift s l r = Property s $ " ++ shift_lambda] + else []) where arg_tys = args inst_ty -- eg Int -> Int -> a @@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries) [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons _ -> False + -- eg SomeType# -> Int# -> SomeType# + mb_shiftable_tys = case arg_tys of + [ty1,"Int#"] -> let res_type = getResultType inst_ty + in ty1 == res_type && ty1 `elem` shiftableTyCons + _ -> False + mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")") + mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))") vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys) @@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries) , (testable (ty po)) = let testPrimOpHow = if is_divLikeOp po then "testPrimopDivLike" + else if is_shiftLikeOp po + then "testPrimopShift" else "testPrimop" qualOp qualification = let qName = wrap qualification poName @@ -784,6 +797,27 @@ gen_foundation_tests (Info _ entries) testableTyCon _ = False divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" ,"Int8#", "Int16#", "Int32#", "Int64#"] + shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" + ,"Int8#", "Int16#", "Int32#", "Int64#"] + + shiftBoundType :: String -> String + shiftBoundType "Int8#" = "Int8" + shiftBoundType "Int16#" = "Int16" + shiftBoundType "Int32#" = "Int32" + shiftBoundType "Int64#" = "Int64" + shiftBoundType "Word8#" = "Int8" -- Word8 uses Int8 bound + shiftBoundType "Word16#" = "Int16" -- Word16 uses Int16 bound + shiftBoundType "Word32#" = "Int32" -- Word32 uses Int32 bound + shiftBoundType "Word64#" = "Int64" -- Word64 uses Int64 bound + shiftBoundType "Int#" = "Int" + shiftBoundType "Word#" = "Int" -- Word uses Int bound + shiftBoundType t = error $ "shiftBoundType: unknown type " ++ t + + getResultType :: Ty -> String + getResultType (TyF _ t2) = getResultType t2 + getResultType (TyApp (TyCon c) []) = c + getResultType (TyUTup _) = "" -- Unboxed tuples can't be shift operations + getResultType t = error $ "getResultType: unexpected type " ++ pprTy t mb_defined_bits :: Entry -> Maybe Word mb_defined_bits op@(PrimOpSpec{}) = ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -1,6 +1,6 @@ module Syntax where -import Data.List (nub) +import Data.List (nub, isInfixOf) ------------------------------------------------------------------ -- Abstract syntax ----------------------------------------------- @@ -66,6 +66,21 @@ is_divLikeOp entry = case entry of Just (OptionTrue{}) -> True _ -> False +is_shiftLikeOp :: Entry -> Bool +is_shiftLikeOp entry = case entry of + PrimOpSpec{} -> has_shift_like + PseudoOpSpec{} -> has_shift_like + PrimVecOpSpec{} -> has_shift_like + PrimTypeSpec{} -> False + PrimVecTypeSpec{} -> False + Section{} -> False + where + has_shift_like = case entry of + PrimOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n + PseudoOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n + PrimVecOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n + _ -> False + -- a binding of property to value data Option = OptionFalse String -- name = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed60877eeae5f76adc06b1b6f9628c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed60877eeae5f76adc06b1b6f9628c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/supersven/fix-foundation-test-shift-amounts
by Sven Tennie (＠supersven) 27 Aug '25

27 Aug '25

Sven Tennie pushed new branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/fix-foundation-test… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26346] 6 commits: tests: disable T22859 under LLVM
by Simon Peyton Jones (＠simonpj) 27 Aug '25

27 Aug '25

Simon Peyton Jones pushed to branch wip/T26346 at Glasgow Haskell Compiler / GHC Commits: 37655c46 by Teo Camarasu at 2025-08-26T15:24:51-04:00 tests: disable T22859 under LLVM This test was failing under the LLVM backend since the allocations differ from the NCG. Resolves #26282 - - - - - 2cbba9d6 by Teo Camarasu at 2025-08-26T15:25:33-04:00 base-exports: update version numbers As the version of the compiler has been bumped, a lot of the embedded version numbers will need to be updated if we ever run this test with `--test-accept` so let's just update them now, and keep future diffs clean. - - - - - f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00 Import new name for 'utimbuf' on windows to fix #26337 Fixes an `-Wincompatible-pointer-types` instance that turns into an error on recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross. This long-standing warning has been present at least since 9.4: ``` C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error: warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types] | 26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} | ^ HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} ^~ C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error: note: passing argument to parameter '_Utimbuf' here | 109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { | ^ __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { ``` - - - - - ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - 00478944 by Simon Peyton Jones at 2025-08-27T16:48:30+01:00 Comments only - - - - - 623d1610 by Simon Peyton Jones at 2025-08-27T16:49:13+01:00 Type-family occurs check in unification The occurs check in `GHC.Core.Unify.uVarOrFam` was inadequate in dealing with type families. Better now. See Note [The occurs check in the Core unifier]. As I did this I realised that the whole apartness thing is trickier than I thought: see the new Note [Shortcomings of the apartness test] - - - - - 35 changed files: - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/.gitignore - 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/rts/all.T - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T - + testsuite/tests/typecheck/should_compile/T26346.hs - + testsuite/tests/typecheck/should_compile/T26358.hs - testsuite/tests/typecheck/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9d194118242f03283813c7b823439… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9d194118242f03283813c7b823439… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26331] Fix deep subsumption again
by Simon Peyton Jones (＠simonpj) 27 Aug '25

27 Aug '25

Simon Peyton Jones pushed to branch wip/T26331 at Glasgow Haskell Compiler / GHC Commits: 92ff5c6b by Simon Peyton Jones at 2025-08-27T16:42:55+01:00 Fix deep subsumption again This commit fixed #26255: commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1 Author: sheaf <sam.derbyshire(a)gmail.com> Date: Mon Aug 11 15:50:47 2025 +0200 Improve deep subsumption This commit improves the DeepSubsumption sub-typing implementation in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back to unification. But alas it still wasn't quite right for view patterns: #26331 This MR does a generalisation to fix it. A bit of a sledgehammer to crack a nut, but nice. * Add a field `ir_inst :: InferInstFlag` to `InferResult`, where ``` data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho ``` * The flag says exactly how much `fillInferResult` should instantiate before filling the hole. * We can also use this to replace the previous very ad-hoc `tcInferSigma` that was used to implement GHCi's `:type` command. - - - - - 12 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.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/Module.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -16,7 +16,6 @@ module GHC.Tc.Gen.App ( tcApp - , tcInferSigma , tcExprPrag ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) @@ -165,26 +164,6 @@ Note [Instantiation variables are short lived] -} -{- ********************************************************************* -* * - tcInferSigma -* * -********************************************************************* -} - -tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType --- Used only to implement :type; see GHC.Tc.Module.tcRnExpr --- True <=> instantiate -- return a rho-type --- False <=> don't instantiate -- return a sigma-type -tcInferSigma inst (L loc rn_expr) - = addExprCtxt rn_expr $ - setSrcSpanA loc $ - do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr - ; do_ql <- wantQuickLook rn_fun - ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args - ; _ <- tcValArgs do_ql inst_args - ; return app_res_sigma } - {- ********************************************************************* * * Typechecking n-ary applications @@ -219,7 +198,7 @@ using the application chain route, and we can just recurse to tcExpr. A "head" has three special cases (for which we can infer a polytype using tcInferAppHead_maybe); otherwise is just any old expression (for -which we can infer a rho-type (via tcInfer). +which we can infer a rho-type (via runInferExpr). There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because we can't get a polytype from them. @@ -403,13 +382,18 @@ tcApp rn_expr exp_res_ty -- Step 2: Infer the type of `fun`, the head of the application ; (tc_fun, fun_sigma) <- tcInferAppHead fun ; let tc_head = (tc_fun, fun_ctxt) + inst_final = case exp_res_ty of + Infer (IR {ir_inst=IIF_Sigma}) -> False + _ -> True + -- inst_fina: top-instantiate the result type of the application, + -- EXCEPT if we are trying to infer a sigma-type -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun ; (inst_args, app_res_rho) <- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] - tcInstFun do_ql True tc_head fun_sigma rn_args + tcInstFun do_ql inst_final tc_head fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -420,6 +404,7 @@ tcApp rn_expr exp_res_ty app_res_rho exp_res_ty -- Step 4.2: typecheck the arguments ; tc_args <- tcValArgs NoQL inst_args + -- Step 4.3: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } @@ -427,15 +412,18 @@ tcApp rn_expr exp_res_ty -- Step 5.1: Take a quick look at the result type ; quickLookResultType app_res_rho exp_res_ty + -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables ; tc_args <- tcValArgs DoQL inst_args + -- Step 5.3: zonk to expose the polymophism hidden under -- QuickLook instantiation variables in `app_res_rho` ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho + -- Step 5.4: subsumption check against the expected type ; res_wrap <- checkResultTy rn_expr tc_head inst_args - app_res_rho exp_res_ty + app_res_rho exp_res_ty -- Step 5.5: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } } @@ -470,32 +458,12 @@ checkResultTy :: HsExpr GhcRn -> (HsExpr GhcTc, AppCtxt) -- Head -> [HsExprArg p] -- Arguments, just error messages -> TcRhoType -- Inferred type of the application; zonked to - -- expose foralls, but maybe not deeply instantiated + -- expose foralls, but maybe not /deeply/ instantiated -> ExpRhoType -- Expected type; this is deeply skolemised -> TcM HsWrapper checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res) - = fillInferResultDS (exprCtOrigin rn_expr) app_res_rho inf_res - -- See Note [Deeply instantiate in checkResultTy when inferring] - -{- Note [Deeply instantiate in checkResultTy when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To accept the following program (T26225b) with -XDeepSubsumption, we need to -deeply instantiate when inferring in checkResultTy: - - f :: Int -> (forall a. a->a) - g :: Int -> Bool -> Bool - - test b = - case b of - True -> f - False -> g - -If we don't deeply instantiate in the branches of the case expression, we will -try to unify the type of 'f' with that of 'g', which fails. If we instead -deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha' -which then successfully unifies with the type of 'g' when we come to fill the -'InferResult' hole a second time for the second case branch. --} + = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res + -- fillInferResult does deep instantiation if DeepSubsumption is on checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty) -- Unify with expected type from the context @@ -651,18 +619,16 @@ quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey] ********************************************************************* -} tcInstFun :: QLFlag - -> Bool -- False <=> Instantiate only /inferred/ variables at the end + -> Bool -- False <=> Instantiate only /top-level, inferred/ variables; -- so may return a sigma-type - -- True <=> Instantiate all type variables at the end: - -- return a rho-type - -- The /only/ call site that passes in False is the one - -- in tcInferSigma, which is used only to implement :type - -- Otherwise we do eager instantiation; in Fig 5 of the paper + -- True <=> Instantiate /top-level, invisible/ type variables; + -- always return a rho-type (but not a deep-rho type) + -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type -> (HsExpr GhcTc, AppCtxt) -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] - , TcSigmaType ) + , TcSigmaType ) -- Does not instantiate trailing invisible foralls -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). @@ -704,13 +670,9 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args _ -> False inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool - -- True <=> instantiate a tyvar with this ForAllTyFlag + -- True <=> instantiate a tyvar that has this ForAllTyFlag inst_fun [] | inst_final = isInvisibleForAllTyFlag | otherwise = const False - -- Using `const False` for `:type` avoids - -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b` - -- turning into `forall a {r2} (b :: TYPE r2). a -> b`. - -- See #21088. inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag inst_fun _ = isInferredForAllTyFlag ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -1305,8 +1305,8 @@ tcMonoBinds is_rec sig_fn no_gen do { mult <- newMultiplicityVar ; ((co_fn, matches'), rhs_ty') - <- tcInferFRR (FRRBinder name) $ \ exp_ty -> - -- tcInferFRR: the type of a let-binder must have + <- runInferRhoFRR (FRRBinder name) $ \ exp_ty -> + -- runInferFRRExpr: the type of a let-binder must have -- a fixed runtime rep. See #23176 tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ -- We extend the error context even for a non-recursive @@ -1333,8 +1333,8 @@ tcMonoBinds is_rec sig_fn no_gen = addErrCtxt (PatMonoBindsCtxt pat grhss) $ do { mult <- tcMultAnnOnPatBind mult_ann - ; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty -> - -- tcInferFRR: the type of each let-binder must have + ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty -> + -- runInferFRRExpr: the type of each let-binder must have -- a fixed runtime rep. See #23176 tcGRHSsPat mult grhss exp_ty @@ -1522,7 +1522,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a -- See Note [Typechecking pattern bindings] ; ((pat', nosig_mbis), pat_ty) <- addErrCtxt (PatMonoBindsCtxt pat grhss) $ - tcInferFRR FRRPatBind $ \ exp_ty -> + runInferSigmaFRR FRRPatBind $ \ exp_ty -> tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $ -- The above inferred type get an unrestricted multiplicity. It may be -- worth it to try and find a finer-grained multiplicity here ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, - tcInferRho, tcInferRhoNC, + tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC, tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, @@ -233,17 +233,24 @@ tcPolyExprCheck expr res_ty * * ********************************************************************* -} +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +tcInferSigma = tcInferExpr IIF_Sigma + tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. -tcInferRho (L loc expr) - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad +tcInferRho = tcInferExpr IIF_DeepRho +tcInferRhoNC = tcInferExprNC IIF_DeepRho + +tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) +tcInferExpr iif (L loc expr) + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] - do { (expr', rho) <- tcInfer (tcExpr expr) + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) ; return (L loc expr', rho) } -tcInferRhoNC (L loc expr) - = setSrcSpanA loc $ - do { (expr', rho) <- tcInfer (tcExpr expr) +tcInferExprNC iif (L loc expr) + = setSrcSpanA loc $ + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) ; return (L loc expr', rho) } --------------- @@ -878,7 +885,7 @@ tcInferTupArgs boxity args ; return (Missing (Scaled mult arg_ty), arg_ty) } tc_infer_tup_arg i (Present x lexpr@(L l expr)) = do { (expr', arg_ty) <- case boxity of - Unboxed -> tcInferFRR (FRRUnboxedTuple i) (tcPolyExpr expr) + Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr) Boxed -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind ; L _ expr' <- tcCheckPolyExpr lexpr arg_ty ; return (expr', arg_ty) } ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -1,8 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) -import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR - , SyntaxOpType +import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR + , SyntaxOpType, InferInstFlag , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.BasicTypes( TcCompleteSig ) @@ -33,6 +33,8 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) + tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -556,7 +556,7 @@ tcInferAppHead (fun,ctxt) do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) - Nothing -> tcInfer (tcExpr fun) } + Nothing -> runInferRho (tcExpr fun) } tcInferAppHead_maybe :: HsExpr GhcRn -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1063,9 +1063,9 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) - tc_infer_hs_type mode rn_ty - = tcInfer $ \exp_kind -> tcHsType mode rn_ty exp_kind + = runInferKind $ \exp_kind -> + tcHsType mode rn_ty exp_kind {- Note [Typechecking HsCoreTys] @@ -1985,7 +1985,7 @@ checkExpKind rn_ty ty ki (Check ki') = checkExpKind _rn_ty ty ki (Infer cell) = do -- NB: do not instantiate. -- See Note [Do not always instantiate eagerly in types] - co <- fillInferResult ki cell + co <- fillInferResultNoInst ki cell pure (ty `mkCastTy` co) --------------------------- ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1034,7 +1034,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names ; tcExtendIdEnv tup_ids $ do { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInfer $ \ exp_ty -> + <- runInferRho $ \ exp_ty -> tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) @@ -1046,7 +1046,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) - <- tcInfer $ \ exp_ty -> + <- runInferRho $ \ exp_ty -> tcSyntaxOp DoOrigin mfix_op [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ \ _ _ -> return () @@ -1172,7 +1172,7 @@ tcApplicativeStmts tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpType + ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; let fun_ty = mkVisFunTysMany pat_tys body_ty ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -26,7 +26,7 @@ where import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr ) import GHC.Hs import GHC.Hs.Syn.Type @@ -220,7 +220,7 @@ tcInferPat :: FixedRuntimeRepContext -> TcM a -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR) tcInferPat frr_orig ctxt pat thing_inside - = tcInferFRR frr_orig $ \ exp_ty -> + = runInferSigmaFRR frr_orig $ \ exp_ty -> tc_lpat (unrestricted exp_ty) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } @@ -694,15 +694,17 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- restriction need to be put in place, if any, for linear view -- patterns to desugar to type-correct Core. - ; (expr',expr_ty) <- tcInferRho expr - -- Note [View patterns and polymorphism] + ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr + -- IIF_ShallowRho: do not perform deep instantiation, regardless of + -- DeepSubsumption (Note [View patterns and polymorphism]) + -- But we must do top-instantiation to expose the arrow to matchActualFunTy -- Expression must be a function ; let herald = ExpectedFunTyViewPat $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) - <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty + <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho -- See Note [View patterns and polymorphism] - -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) + -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma) -- Check that overall pattern is more polymorphic than arg type ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty @@ -715,11 +717,11 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; pat_ty <- readExpType h_pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper (Scaled w pat_ty) inf_res_sigma - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" - -- (pat_ty -> inf_res_sigma) - -- NB: pat_ty comes from matchActualFunTy, so it has a - -- fixed RuntimeRep, as needed to call mkWpFun. - ; let + -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" + -- (pat_ty -> inf_res_sigma) + -- NB: pat_ty comes from matchActualFunTy, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. + expr_wrap = expr_wrap2' <.> expr_wrap1 ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } @@ -735,11 +737,14 @@ Consider this exotic example: The expression (pair True) should have type pair True :: Int -> forall b. b -> (Int,b) so that it is ready to consume the incoming Int. It should be an -arrow type (t1 -> t2); hence using (tcInferRho expr). +arrow type (t1 -> t2); and we must not instantiate that `forall b`, +/even with DeepSubsumption/. Hence using `IIF_ShallowRho` Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to. Fortunately that's what matchActualFunTy returns anyway. + +Another example is #26331. -} -- Type signatures in patterns @@ -768,8 +773,7 @@ Fortunately that's what matchActualFunTy returns anyway. penv pats thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi - (ListPat elt_ty pats') pat_ty, res) -} + (ListPat elt_ty pats') pat_ty, res) } TuplePat _ pats boxity -> do { let arity = length pats ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -62,7 +62,6 @@ import GHC.Tc.Gen.Match import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) import GHC.Tc.Zonk.Type import GHC.Tc.Gen.Expr -import GHC.Tc.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence @@ -2628,10 +2627,11 @@ tcRnExpr hsc_env mode rdr_expr failIfErrsM ; -- Typecheck the expression - ((tclvl, res_ty), lie) + ((tclvl, (_tc_expr, res_ty)), lie) <- captureTopConstraints $ pushTcLevelM $ - tcInferSigma inst rn_expr ; + (if inst then tcInferRho rn_expr + else tcInferSigma rn_expr); -- Generalise uniq <- newUnique ; ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -65,7 +65,7 @@ module GHC.Tc.Utils.TcMType ( -- Expected types ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType, newInferExpType, newInferExpTypeFRR, - tcInfer, tcInferFRR, + runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR, readExpType, readExpType_maybe, readScaledExpType, expTypeToType, scaledExpTypeToType, checkingExpType_maybe, checkingExpType, @@ -438,30 +438,29 @@ See test case T21325. -- actual data definition is in GHC.Tc.Utils.TcType -newInferExpType :: TcM ExpType -newInferExpType = new_inferExpType Nothing +newInferExpType :: InferInstFlag -> TcM ExpType +newInferExpType iif = new_inferExpType iif IFRR_Any -newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR -newInferExpTypeFRR frr_orig +newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR +newInferExpTypeFRR iif frr_orig = do { th_lvl <- getThLevel - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | TypedBrack _ <- th_lvl - -> new_inferExpType Nothing + ; let mb_frr = case th_lvl of + TypedBrack {} -> IFRR_Any + _ -> IFRR_Check frr_orig + -- mb_frr: see [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | otherwise - -> new_inferExpType (Just frr_orig) } + ; new_inferExpType iif mb_frr } -new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType -new_inferExpType mb_frr_orig +new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType +new_inferExpType iif ifrr = do { u <- newUnique ; tclvl <- getTcLevel ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) ; ref <- newMutVar Nothing ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref - , ir_frr = mb_frr_orig })) } + , ir_inst = iif, ir_frr = ifrr + , ir_ref = ref })) } -- | Extract a type out of an ExpType, if one exists. But one should always -- exist. Unless you're quite sure you know what you're doing. @@ -515,12 +514,12 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl where -- See Note [TcLevel of ExpType] new_meta = case mb_frr of - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } - Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr - ; return tau } + IFRR_Check frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -537,20 +536,31 @@ Note [fillInferResult] in GHC.Tc.Utils.Unify. -- | Infer a type using a fresh ExpType -- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" -- --- Use 'tcInferFRR' if you require the type to have a fixed +-- Use 'runInferFRR' if you require the type to have a fixed -- runtime representation. -tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer = tc_infer Nothing +runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInferSigma = runInfer IIF_Sigma IFRR_Any --- | Like 'tcInfer', except it ensures that the resulting type +runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) +runInferRho = runInfer IIF_DeepRho IFRR_Any + +runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +-- Used for kind-checking types, where we never want deep instantiation, +-- nor FRR checkes +runInferKind = runInfer IIF_Sigma IFRR_Any + +-- | Like 'tcInferExpr', except it ensures that the resulting type -- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in -- GHC.Tc.Utils.Concrete. -tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) -tcInferFRR frr_orig = tc_infer (Just frr_orig) +runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR) +runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig) + +runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) +runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig) -tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tc_infer mb_frr tc_check - = do { res_ty <- new_inferExpType mb_frr +runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInfer iif mb_frr tc_check + = do { res_ty <- new_inferExpType iif mb_frr ; result <- tc_check res_ty ; res_ty <- readExpType res_ty ; return (result, res_ty) } ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -24,14 +24,14 @@ module GHC.Tc.Utils.TcType ( -------------------------------- -- Types TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR, - TcRhoType, TcTauType, TcPredType, TcThetaType, + TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, - ExpType(..), ExpKind, InferResult(..), + ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, - ExpRhoType, + ExpRhoType, ExpRhoTypeFRR, mkCheckExpType, checkingExpType_maybe, checkingExpType, @@ -380,6 +380,7 @@ type TcSigmaType = TcType -- See Note [Return arguments with a fixed RuntimeRep. type TcSigmaTypeFRR = TcSigmaType -- TODO: consider making this a newtype. +type TcRhoTypeFRR = TcRhoType type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType @@ -408,9 +409,13 @@ data InferResult , ir_lvl :: TcLevel -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType - , ir_frr :: Maybe FixedRuntimeRepContext + , ir_frr :: InferFRRFlag -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType + , ir_inst :: InferInstFlag + -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling, + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + , ir_ref :: IORef (Maybe TcType) } -- ^ The type that fills in this hole should be a @Type@, -- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@. @@ -419,26 +424,48 @@ data InferResult -- @rr@ must be concrete, in the sense of Note [Concrete types] -- in GHC.Tc.Utils.Concrete. -type ExpSigmaType = ExpType +data InferFRRFlag + = IFRR_Check -- Check that the result type has a fixed runtime rep + FixedRuntimeRepContext -- Typically used for function arguments and lambdas + + | IFRR_Any -- No need to check for fixed runtime-rep + +data InferInstFlag -- Specifies whether the inference should return an uninstantiated + -- SigmaType, or a (possibly deeply) instantiated RhoType + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + + = IIF_Sigma -- Trying to infer a SigmaType + -- Don't instantiate at all, regardless of DeepSubsumption + -- Typically used when inferring the type of a pattern + + | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) + -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole + -- Typically used when inferring the type of an expression + + | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) + -- If DeepSubsumption is off, same as IIF_ShallowRho + -- If DeepSubsumption is on, instantiate deeply before filling the hole + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + -- Invariant: in ExpRhoType, if -XDeepSubsumption is on, + -- and we are in checking mode (i.e. the ExpRhoType is (Check rho)), + -- then the `rho` is deeply skolemised -- | An 'ExpType' which has a fixed RuntimeRep. -- -- For a 'Check' 'ExpType', the stored 'TcType' must have -- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr' --- field must be of the form @Just frr_orig@. -type ExpTypeFRR = ExpType +-- field must be of the form @IFRR_Check frr_orig@. +type ExpTypeFRR = ExpType -- | Like 'TcSigmaTypeFRR', but for an expected type. -- -- See 'ExpTypeFRR'. type ExpSigmaTypeFRR = ExpTypeFRR +type ExpRhoTypeFRR = ExpTypeFRR -- TODO: consider making this a newtype. -type ExpRhoType = ExpType - -- Invariant: if -XDeepSubsumption is on, - -- and we are checking (i.e. the ExpRhoType is (Check rho)), - -- then the `rho` is deeply skolemised - -- | Like 'ExpType', but on kind level type ExpKind = ExpType @@ -447,12 +474,17 @@ instance Outputable ExpType where ppr (Infer ir) = ppr ir instance Outputable InferResult where - ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr }) - = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl) + ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst }) + = text "Infer" <> parens (pp_inst <> pp_frr) + <> braces (ppr u <> comma <> ppr lvl) where - mb_frr_text = case mb_frr of - Just _ -> text "FRR" - Nothing -> empty + pp_inst = case inst of + IIF_Sigma -> text "Sigma" + IIF_ShallowRho -> text "ShallowRho" + IIF_DeepRho -> text "DeepRho" + pp_frr = case mb_frr of + IFRR_Check {} -> text ",FRR" + IFRR_Any -> empty -- | Make an 'ExpType' suitable for checking. mkCheckExpType :: TcType -> ExpType ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Tc.Utils.Unify ( -- Skolemisation DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS, tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType, - deeplyInstantiate, + dsInstantiate, -- Various unifications unifyType, unifyKind, unifyInvisibleType, @@ -40,7 +40,6 @@ module GHC.Tc.Utils.Unify ( -------------------------------- -- Holes - tcInfer, matchExpectedListTy, matchExpectedTyConApp, matchExpectedAppTy, @@ -60,7 +59,7 @@ module GHC.Tc.Utils.Unify ( simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..), - fillInferResult, fillInferResultDS + fillInferResult, fillInferResultNoInst ) where import GHC.Prelude @@ -801,13 +800,13 @@ matchExpectedFunTys :: forall a. -- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{} matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside = do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity] - ; res_ty <- newInferExpType + ; res_ty <- newInferExpType (ir_inst inf_res) ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys ; res_ty <- readExpType res_ty -- NB: mkScaledFunTys arg_tys res_ty does not contain any foralls -- (even nested ones), so no need to instantiate. - ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res + ; co <- fillInferResultNoInst (mkScaledFunTys arg_tys res_ty) inf_res ; return (mkWpCastN co, result) } matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside @@ -914,10 +913,10 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) +new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy - ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) @@ -1075,18 +1074,6 @@ matchExpectedAppTy orig_ty * ********************************************************************** -} -{- Note [inferResultToType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -expTypeToType and inferResultType convert an InferResult to a monotype. -It must be a monotype because if the InferResult isn't already filled in, -we fill it in with a unification variable (hence monotype). So to preserve -order-independence we check for mono-type-ness even if it *is* filled in -already. - -See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and -Note [fillInferResult]. --} - -- | Fill an 'InferResult' with the given type. -- -- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@, @@ -1098,14 +1085,14 @@ Note [fillInferResult]. -- The stored type @t2@ is at the same level as given by the -- 'ir_lvl' field. -- - FRR invariant. --- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed +-- Whenever the 'ir_frr' field is `IFRR_Check`, @t2@ is guaranteed -- to have a syntactically fixed RuntimeRep, in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN -fillInferResult act_res_ty (IR { ir_uniq = u - , ir_lvl = res_lvl - , ir_frr = mb_frr - , ir_ref = ref }) +fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN +fillInferResultNoInst act_res_ty (IR { ir_uniq = u + , ir_lvl = res_lvl + , ir_frr = mb_frr + , ir_ref = ref }) = do { mb_exp_res_ty <- readTcRef ref ; case mb_exp_res_ty of Just exp_res_ty @@ -1126,7 +1113,7 @@ fillInferResult act_res_ty (IR { ir_uniq = u ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty ; cur_lvl <- getTcLevel ; unless (cur_lvl `sameDepthAs` res_lvl) $ - ensureMonoType act_res_ty + ensureMonoType act_res_ty -- See (FIR1) ; unifyType Nothing act_res_ty exp_res_ty } Nothing -> do { traceTc "Filling inferred ExpType" $ @@ -1140,16 +1127,28 @@ fillInferResult act_res_ty (IR { ir_uniq = u -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing'). ; (frr_co, act_res_ty) <- case mb_frr of - Nothing -> return (mkNomReflCo act_res_ty, act_res_ty) - Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty + IFRR_Any -> return (mkNomReflCo act_res_ty, act_res_ty) + IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty -- Compose the two coercions. ; let final_co = prom_co `mkTransCo` frr_co ; writeTcRef ref (Just act_res_ty) - ; return final_co } - } + ; return final_co } } + +fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper +-- See Note [Instantiation of InferResult] +fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif }) + = case iif of + IIF_Sigma -> do { co <- fillInferResultNoInst res_ty ires + ; return (mkWpCastN co) } + IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } + IIF_DeepRho -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } {- Note [fillInferResult] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1210,39 +1209,96 @@ For (2), we simply look to see if the hole is filled already. - if it is filled, we simply unify with the type that is already there -There is one wrinkle. Suppose we have - case e of - T1 -> e1 :: (forall a. a->a) -> Int - G2 -> e2 -where T1 is not GADT or existential, but G2 is a GADT. Then suppose the -T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. -But now the G2 alternative must not *just* unify with that else we'd risk -allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first -we'd have filled the hole with a unification variable, which enforces a -monotype. - -So if we check G2 second, we still want to emit a constraint that restricts -the RHS to be a monotype. This is done by ensureMonoType, and it works -by simply generating a constraint (alpha ~ ty), where alpha is a fresh +(FIR1) There is one wrinkle. Suppose we have + case e of + T1 -> e1 :: (forall a. a->a) -> Int + G2 -> e2 + where T1 is not GADT or existential, but G2 is a GADT. Then suppose the + T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. + But now the G2 alternative must not *just* unify with that else we'd risk + allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first + we'd have filled the hole with a unification variable, which enforces a + monotype. + + So if we check G2 second, we still want to emit a constraint that restricts + the RHS to be a monotype. This is done by ensureMonoType, and it works + by simply generating a constraint (alpha ~ ty), where alpha is a fresh unification variable. We discard the evidence. --} +Note [Instantiation of InferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking expressions (not types, not patterns), we always almost +always instantiate before filling in `InferResult`, so that the result is a +TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag` +field of `InferResult`. --- | A version of 'fillInferResult' that also performs deep instantiation --- when deep subsumption is enabled. --- --- See also Note [Instantiation of InferResult]. -fillInferResultDS :: CtOrigin -> TcRhoType -> InferResult -> TcM HsWrapper -fillInferResultDS ct_orig rho inf_res - = do { massertPpr (isRhoTy rho) $ - vcat [ text "fillInferResultDS: input type is not a rho-type" - , text "ty:" <+> ppr rho ] - ; ds_flag <- getDeepSubsumptionFlag - ; case ds_flag of - Shallow -> mkWpCastN <$> fillInferResult rho inf_res - Deep -> do { (inst_wrap, rho') <- deeplyInstantiate ct_orig rho - ; co <- fillInferResult rho' inf_res - ; return (mkWpCastN co <.> inst_wrap) } } +If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled, +we instantiate deeply. See `tcInferResult`. + +Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type". +Why is this the common case? See #17173 for discussion. Here are some examples +of why: + +1. Consider + f x = (*) + We want to instantiate the type of (*) before returning, else we + will infer the type + f :: forall {a}. a -> forall b. Num b => b -> b -> b + This is surely confusing for users. + + And worse, the monomorphism restriction won't work properly. The MR is + dealt with in simplifyInfer, and simplifyInfer has no way of + instantiating. This could perhaps be worked around, but it may be + hard to know even when instantiation should happen. + +2. Another reason. Consider + f :: (?x :: Int) => a -> a + g y = let ?x = 3::Int in f + Here want to instantiate f's type so that the ?x::Int constraint + gets discharged by the enclosing implicit-parameter binding. + +3. Suppose one defines plus = (+). If we instantiate lazily, we will + infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism + restriction compels us to infer + plus :: Integer -> Integer -> Integer + (or similar monotype). Indeed, the only way to know whether to apply + the monomorphism restriction at all is to instantiate + +HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning +"return a sigma-type": + +* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type + command, we want to return a completely uninstantiated type. + See Note [Implementing :type] in GHC.Tc.Module. + +* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate + at all. See calls to `runInferHsType` + +* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of + `runInferSigmaFRR` in GHC.Tc.Gen.Pat + +* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate + but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism] + in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho. + +Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough? +Answer: to accept the following program (T26225b) with -XDeepSubsumption, we +need to deeply instantiate when inferring in checkResultTy: + + f :: Int -> (forall a. a->a) + g :: Int -> Bool -> Bool + + test b = + case b of + True -> f + False -> g + +If we don't deeply instantiate in the branches of the case expression, we will +try to unify the type of 'f' with that of 'g', which fails. If we instead +deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha' +which then successfully unifies with the type of 'g' when we come to fill the +'InferResult' hole a second time for the second case branch. +-} {- ************************************************************************ @@ -1276,7 +1332,7 @@ Consider Does `f` have an ambiguous type? The ambiguity check usually checks that this definition of f' would typecheck, where f' has the exact same type as f: - f' :: (forall b. Eq b => a -> a) -> Intp +p f' :: (forall b. Eq b => a -> a) -> Intp f' = f This will be /rejected/ with DeepSubsumption but /accepted/ with @@ -1337,7 +1393,7 @@ tcSubTypeMono rn_expr act_ty exp_ty , text "act_ty:" <+> ppr act_ty , text "rn_expr:" <+> ppr rn_expr]) $ case exp_ty of - Infer inf_res -> fillInferResult act_ty inf_res + Infer inf_res -> fillInferResultNoInst act_ty inf_res Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty ------------------------ @@ -1351,7 +1407,7 @@ tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected tcSubTypePat _ _ (Infer inf_res) ty_expected - = do { co <- fillInferResult ty_expected inf_res + = do { co <- fillInferResultNoInst ty_expected inf_res -- In patterns we do not instantatiate ; return (mkWpCastN (mkSymCo co)) } @@ -1377,7 +1433,7 @@ tcSubTypeDS rn_expr act_rho exp_rho -- | Checks that the 'actual' type is more polymorphic than the 'expected' type. tcSubType :: CtOrigin -- ^ Used when instantiating -> UserTypeCtxt -- ^ Used when skolemising - -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) -> TcSigmaType -- ^ Actual type -> ExpRhoType -- ^ Expected type -> TcM HsWrapper @@ -1386,10 +1442,7 @@ tcSubType inst_orig ctxt m_thing ty_actual res_ty Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt ty_actual ty_expected - Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual - -- See Note [Instantiation of InferResult] - ; inst <- fillInferResultDS inst_orig rho inf_res - ; return (inst <.> wrap) } + Infer inf_res -> fillInferResult inst_orig ty_actual inf_res --------------- tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we @@ -1428,47 +1481,6 @@ addSubTypeCtxt ty_actual ty_expected thing_inside ; return (tidy_env, SubTypeCtxt ty_expected ty_actual) } -{- Note [Instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking expressions (not types, not patterns), we always instantiate -before filling in InferResult, so that the result is a TcRhoType. -See #17173 for discussion. - -For example: - -1. Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the monomorphism restriction won't work properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - -2. Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -3. Suppose one defines plus = (+). If we instantiate lazily, we will - infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism - restriction compels us to infer - plus :: Integer -> Integer -> Integer - (or similar monotype). Indeed, the only way to know whether to apply - the monomorphism restriction at all is to instantiate - -There is one place where we don't want to instantiate eagerly, -namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type -command. See Note [Implementing :type] in GHC.Tc.Module. - -This also means that, if DeepSubsumption is enabled, we should also instantiate -deeply; we do this by using fillInferResultDS. --} - --------------- tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify -> CtOrigin -- Used when instantiating @@ -2133,7 +2145,17 @@ deeplySkolemise skol_info ty = return (idHsWrapper, [], [], substTy subst ty) -- substTy is a quick no-op on an empty substitution +dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption +dsInstantiate orig ty + = do { ds_flag <- getDeepSubsumptionFlag + ; case ds_flag of + Shallow -> topInstantiate orig ty + Deep -> deeplyInstantiate orig ty } + deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Instantiate invisible foralls, even ones nested +-- (to the right) under arrows deeplyInstantiate orig ty = go init_subst ty where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/92ff5c6bc1b4677343fc7550636a022… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/92ff5c6bc1b4677343fc7550636a022… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26331] 9 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Simon Peyton Jones (＠simonpj) 27 Aug '25

27 Aug '25

Simon Peyton Jones pushed to branch wip/T26331 at Glasgow Haskell Compiler / GHC Commits: 5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00 Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)" This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd - - - - - 10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. - - - - - bedc1004 by Cheng Shao at 2025-08-26T09:31:18-04:00 compiler: use zero cost coerce in hoopl setElems/mapToList This patch is a follow-up of !14680 and changes setElems/mapToList in GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel over the keys. - - - - - 13250d97 by Ryan Scott at 2025-08-26T09:31:59-04:00 Reject infix promoted data constructors without DataKinds In the rename, make sure to apply the same `DataKinds` checks for both `HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix promoted data constructors) alike. Fixes #26318. - - - - - 37655c46 by Teo Camarasu at 2025-08-26T15:24:51-04:00 tests: disable T22859 under LLVM This test was failing under the LLVM backend since the allocations differ from the NCG. Resolves #26282 - - - - - 2cbba9d6 by Teo Camarasu at 2025-08-26T15:25:33-04:00 base-exports: update version numbers As the version of the compiler has been bumped, a lot of the embedded version numbers will need to be updated if we ever run this test with `--test-accept` so let's just update them now, and keep future diffs clean. - - - - - f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00 Import new name for 'utimbuf' on windows to fix #26337 Fixes an `-Wincompatible-pointer-types` instance that turns into an error on recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross. This long-standing warning has been present at least since 9.4: ``` C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error: warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types] | 26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} | ^ HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} ^~ C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error: note: passing argument to parameter '_Utimbuf' here | 109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { | ^ __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { ``` - - - - - ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - be2fdbbf by Simon Peyton Jones at 2025-08-27T16:39:49+01:00 Fix deep subsumption again This commit fixed #26255: commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1 Author: sheaf <sam.derbyshire(a)gmail.com> Date: Mon Aug 11 15:50:47 2025 +0200 Improve deep subsumption This commit improves the DeepSubsumption sub-typing implementation in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back to unification. But alas it still wasn't quite right for view patterns: #26133. This MR does a generalisation to fix it. A bit of a sledgehammer to crack a nut, but nice. * Add a field `ir_inst :: InferInstFlag` to `InferResult`, where ``` data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho ``` * The flag says exactly how much `fillInferResult` should instantiate before filling the hole. * We can also use this to replace the previous very ad-hoc `tcInferSigma` that was used to implement GHCi's `:type` command. - - - - - 53 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.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/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - testsuite/.gitignore - 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/lib/stm/T26028.hs - − testsuite/tests/lib/stm/T26028.stdout - − testsuite/tests/lib/stm/all.T - testsuite/tests/rts/all.T - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T - + testsuite/tests/typecheck/should_fail/T26318.hs - + testsuite/tests/typecheck/should_fail/T26318.stderr - testsuite/tests/typecheck/should_fail/all.T - 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/a6c8f7710198b27c13044291a29f30… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6c8f7710198b27c13044291a29f30… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/stack-annotation-with-backtraces] Expose Stack Annotation frames in IPE backtraces by default
by Hannes Siebenhandl (＠fendor) 27 Aug '25

27 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC Commits: 36314d04 by fendor at 2025-08-27T17:09:14+02:00 Expose Stack Annotation frames in IPE backtraces by default When decoding the Haskell-native call stack and displaying the IPE information for the stack frames, we print the `StackAnnotation` of the `AnnFrame` by default. This means, when an exception is thrown, any intermediate stack annotations will be displayed in the `IPE Backtrace`. Example backtrace: ``` Exception: ghc-internal:GHC.Internal.Exception.ErrorCall: Oh no! IPE backtrace: annotateCallStackIO, called at app/Main.hs:48:10 in backtrace-0.1.0.0-inplace-server:Main annotateCallStackIO, called at app/Main.hs:46:13 in backtrace-0.1.0.0-inplace-server:Main Main.handler (app/Main.hs:(46,1)-(49,30)) Main.liftIO (src/Servant/Server/Internal/Handler.hs:30:36-42) Servant.Server.Internal.Delayed.runHandler' (src/Servant/Server/Internal/Handler.hs:27:31-41) Control.Monad.Trans.Resource.runResourceT (./Control/Monad/Trans/Resource.hs:(192,14)-(197,18)) Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:195:20-22) Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:(195,5)-(203,31)) Network.Wai.Handler.Warp.HTTP1.http1server.loop (./Network/Wai/Handler/Warp/HTTP1.hs:(141,9)-(157,42)) HasCallStack backtrace: error, called at app/Main.hs:48:32 in backtrace-0.1.0.0-inplace-server:Main ``` The first two entries have been added by `annotateCallStackIO`, defined in `annotateCallStackIO`. - - - - - 9 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -58,6 +58,7 @@ import Data.Typeable import GHC.Exts import GHC.IO import GHC.Internal.Stack +import GHC.Internal.Stack.Annotation -- Note [User-defined stack annotations for better stack traces] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -127,31 +128,10 @@ import GHC.Internal.Stack -- This means, right now, if you want to reliably capture stack frame annotations, -- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'. --- ---------------------------------------------------------------------------- --- StackAnnotation --- ---------------------------------------------------------------------------- - --- | 'StackAnnotation's are types which can be pushed onto the call stack --- as the payload of 'AnnFrame' stack frames. --- -class StackAnnotation a where - displayStackAnnotation :: a -> String - -- ---------------------------------------------------------------------------- -- Annotations -- ---------------------------------------------------------------------------- --- | --- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. --- When the call stack is annotated with a value of type @a@, behind the scenes it is --- encapsulated in a @SomeStackAnnotation@. --- -data SomeStackAnnotation where - SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation - -instance StackAnnotation SomeStackAnnotation where - displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a - data StringAnnotation where StringAnnotation :: String -> StringAnnotation @@ -175,7 +155,7 @@ instance Show CallStackAnnotation where instance StackAnnotation CallStackAnnotation where displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of [] -> "<unknown source location>" - ((_,srcLoc):_) -> prettySrcLoc srcLoc + ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc -- ---------------------------------------------------------------------------- -- Annotate the CallStack with custom data ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -295,6 +295,7 @@ Library GHC.Internal.Stable GHC.Internal.StableName GHC.Internal.Stack + GHC.Internal.Stack.Annotation GHC.Internal.Stack.CCS GHC.Internal.Stack.CloneStack GHC.Internal.Stack.Constants ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -11,7 +11,7 @@ import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr -import GHC.Internal.Data.Maybe (fromMaybe) +import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe) import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack @@ -144,7 +144,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Internal.Stack.Annotation where + +import GHC.Internal.Base +import GHC.Internal.Data.Typeable + +-- ---------------------------------------------------------------------------- +-- StackAnnotation +-- ---------------------------------------------------------------------------- + +-- | 'StackAnnotation's are types which can be pushed onto the call stack +-- as the payload of 'AnnFrame' stack frames. +-- +class StackAnnotation a where + displayStackAnnotation :: a -> String + +-- ---------------------------------------------------------------------------- +-- Annotations +-- ---------------------------------------------------------------------------- + +-- | +-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. +-- When the call stack is annotated with a value of type @a@, behind the scenes it is +-- encapsulated in a @SomeStackAnnotation@. +-- +data SomeStackAnnotation where + SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation + +instance StackAnnotation SomeStackAnnotation where + displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +24,7 @@ module GHC.Internal.Stack.Decode ( StackEntry(..), -- * Pretty printing prettyStackEntry, + prettyStackFrameWithIpe, ) where @@ -39,6 +41,7 @@ import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Exts +import GHC.Internal.Unsafe.Coerce import GHC.Internal.ClosureTypes import GHC.Internal.Heap.Closures @@ -52,6 +55,7 @@ import GHC.Internal.Heap.Closures ) import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Internal.Heap.InfoTable +import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) @@ -560,6 +564,16 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do -- Pretty printing functions for stack entires, stack frames and provenance info -- ---------------------------------------------------------------------------- +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String +prettyStackFrameWithIpe (frame, mipe) = + case frame of + AnnFrame {annotation = Box someStackAnno } -> + case unsafeCoerce someStackAnno of + SomeStackAnnotation ann -> + Just $ displayStackAnnotation ann + _ -> + (prettyStackEntry . toStackEntry) <$> mipe + prettyStackEntry :: StackEntry -> String prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Stack annotations: -- ann_frame002.hs:18:7 in main:Main -- ann_frame002.hs:12:11 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:18:7 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:12:11 in main:Main Finish some work Some more work in bar 17711 Stack annotations: - bar -- ann_frame002.hs:23:7 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout ===================================== @@ -1,17 +1,17 @@ Stack annotations: -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:13:10 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main +- annotateCallStack, called at ann_frame004.hs:13:10 in main:Main - bar -- ann_frame004.hs:12:7 in main:Main +- annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -10949,10 +10949,6 @@ module System.Mem.Experimental where -- Instances: -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’ @@ -11151,3 +11147,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’ instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -10952,10 +10952,6 @@ module System.Mem.Experimental where -- Instances: -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’ @@ -11154,3 +11150,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’ instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36314d049da3f39f0196877be1c20f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36314d049da3f39f0196877be1c20f5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/9.12.3-backports] llvmGen: Fix built-in variable predicate
by Zubin (＠wz1000) 27 Aug '25

27 Aug '25

Zubin pushed to branch wip/9.12.3-backports at Glasgow Haskell Compiler / GHC Commits: e67ba5ed by Ben Gamari at 2025-08-27T18:49:38+05:30 llvmGen: Fix built-in variable predicate Previously the predicate to identify LLVM builtin global variables was checking for `$llvm` rather than `@llvm` as it should. (cherry picked from commit 6e67fa083a50684e1cfae546e07cab4d4250e871) - - - - - 1 changed file: - compiler/GHC/CmmToLlvm/Base.hs Changes: ===================================== compiler/GHC/CmmToLlvm/Base.hs ===================================== @@ -526,10 +526,10 @@ generateExternDecls = do modifyEnv $ \env -> env { envAliases = emptyUniqSet } return (concat defss, []) --- | Is a variable one of the special @$llvm@ globals? +-- | Is a variable one of the special @\@llvm@ globals? isBuiltinLlvmVar :: LlvmVar -> Bool isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) = - "$llvm" `isPrefixOf` unpackFS lbl + "llvm." `isPrefixOf` unpackFS lbl isBuiltinLlvmVar _ = False -- | Here we take a global variable definition, rename it with a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e67ba5ed9c896235e9c50a20b5062fc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e67ba5ed9c896235e9c50a20b5062fc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26346] Responding to Sam
by Simon Peyton Jones (＠simonpj) 27 Aug '25

27 Aug '25

Simon Peyton Jones pushed to branch wip/T26346 at Glasgow Haskell Compiler / GHC Commits: b9d19411 by Simon Peyton Jones at 2025-08-27T12:35:53+01:00 Responding to Sam - - - - - 3 changed files: - compiler/GHC/Core/Unify.hs - + testsuite/tests/typecheck/should_compile/T26358.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -431,24 +431,7 @@ Wrinkles (ATF12) There is a horrid exception for the injectivity check. See (UR1) in in Note [Specification of unification]. -(ATF13) Consider unifying - [F a, F Int, Int] ~ [Bool, Char, a] - Working left to right you might think we would build the mapping - F a :-> Bool - F Int :-> Char - Now we discover that `a` unifies with `Int`. So really these two lists are Apart - because F Int can't be both Bool and Char. - - But that is very tricky! Perhaps whenever we unify a type variable we should - run it over the domain and (maybe range) of the type-family mapping too? - Sigh. - - For we make no such attempt. The um_fam_env has only pre-substituted types. - Fortunately, while this may make use say MaybeApart when we could say SurelyApart, - it has no effect on the correctness of unification: if we return Unifiable, it - really is Unifiable. - -(ATF14) We have to be careful about the occurs check. +(ATF13) We have to be careful about the occurs check. See Note [The occurs check in the Core unifier] SIDE NOTE. The paper "Closed type families with overlapping equations" @@ -474,6 +457,49 @@ and all is lost. But with the current algorithm we have that a a ~ (Var A) (Var B) is SurelyApart, so the first equation definitely doesn't match and we can try the second, which does. END OF SIDE NOTE. + +Note [Shortcomings of the apartness test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Apartness and type families] is very clever. + +But it still has shortcomings (#26358). Consider unifying + [F a, F Int, Int] ~ [Bool, Char, a] +Working left to right you might think we would build the mapping + F a :-> Bool + F Int :-> Char +Now we discover that `a` unifies with `Int`. So really these two lists are Apart +because F Int can't be both Bool and Char. + +Just the same applies when adding a type-family binding to um_fam_env: + [F (G Float), F Int, G Float] ~ [Bool, Char, Iont] +Again these are Apart, because (G Float = Int), +and (F Int) can't be both Bool and Char + +But achieving this is very tricky! Perhaps whenever we unify a type variable, +or a type family, we should run it over the domain and (maybe range) of the +type-family mapping too? Sigh. + +For now we make no such attempt. +* The um_fam_env has only /un-substituted/ types. +* We look up on ly /un-substituted/ types in um_fam_env + +This may make us say MaybeApart when we could say SurelyApart, but it has no +effect on the correctness of unification: if we return Unifiable, it really is +Unifiable. + +This is all quite subtle. suppose we have: + um_tv_env: c :-> b + um_fam_env F b :-> a +and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will +fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq, +getting: + um_tv_env: a :-> F c, c :-> b + um_fam_env F b :-> a + +Does that loop, like this: + a --> F c --> F b --> a? +No, becuase we do not substitute (F c) to (F b) and then look up in um_fam_env; +we look up only un-substituted types. -} {- ********************************************************************* @@ -1810,6 +1836,7 @@ uVarOrFam env ty1 ty2 kco ----------------------------- -- LHS is a type variable -- The sequence of tests is very similar to go_tv + go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM () go swapped substs lhs@(TyVarLHS tv1) ty2 kco | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1' = -- We already have a substitution for tv1 @@ -1863,7 +1890,7 @@ uVarOrFam env ty1 ty2 kco tv1' = umRnOccL env tv1 ty2_fvs = tyCoVarsOfType ty2 rhs = ty2 `mkCastTy` mkSymCo kco - tv1_is_bindable | not (tv1' `elemVarSet` um_foralls env) + tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs) -- tv1' is not forall-bound, but tv1 can still differ -- from tv1; see Note [Cloning the template binders] -- in GHC.Core.Rules. So give tv1' to um_bind_tv_fun. @@ -1872,7 +1899,8 @@ uVarOrFam env ty1 ty2 kco | otherwise = False - occurs_check = um_unif env && uOccursCheck substs lhs rhs + foralld_tvs = um_foralls env + occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs -- Occurs check, only when unifying -- see Note [Infinitary substitutions] -- Make sure you include `kco` in rhs #14846 @@ -1906,9 +1934,11 @@ uVarOrFam env ty1 ty2 kco -- Now check if we can bind the (F tys) to the RHS -- This can happen even when matching: see (ATF7) | BindMe <- um_bind_fam_fun env tc1 tys1 rhs - = if uOccursCheck substs lhs rhs + = if uOccursCheck substs emptyVarSet lhs rhs then maybeApart MARInfinite - else do { extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13) + else do { extendFamEnv tc1 tys1 rhs + -- We don't substitute tys1 before extending + -- See Note [Shortcomings of the apartness test] ; maybeApart MARTypeFamily } -- Swap in case of (F a b) ~ (G c d e) @@ -1929,6 +1959,7 @@ uVarOrFam env ty1 ty2 kco ----------------------------- -- go_fam_fam: LHS and RHS are both saturated type-family applications, -- for the same type-family F + -- Precondition: um_foralls is empty go_fam_fam substs tc tys1 tys2 kco -- Decompose (F tys1 ~ F tys2): (ATF9) -- Use injectivity information of F: (ATF10) @@ -1950,11 +1981,11 @@ uVarOrFam env ty1 ty2 kco | not (um_unif env) -- Not when matching (ATF11-1) = return () | BindMe <- um_bind_fam_fun env tc tys1 rhs1 - = unless (uOccursCheck substs (TyFamLHS tc tys1) rhs1) $ + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $ extendFamEnv tc tys1 rhs1 -- At this point um_unif=True, so we can unify either way | BindMe <- um_bind_fam_fun env tc tys2 rhs2 - = unless (uOccursCheck substs (TyFamLHS tc tys2) rhs2) $ + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $ extendFamEnv tc tys2 rhs2 | otherwise = return () @@ -1963,12 +1994,15 @@ uVarOrFam env ty1 ty2 kco rhs2 = mkTyConApp tc tys1 `mkCastTy` kco -uOccursCheck :: UMState -> CanEqLHS -> Type -> Bool --- See Note [The occurs check in the Core unifier] and (ATF14) -uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty - = go emptyVarSet ty +uOccursCheck :: UMState + -> TyVarSet -- Bound by enclosing foralls; see (OCU1) + -> CanEqLHS -> Type -- Can we unify (lhs := ty)? + -> Bool +-- See Note [The occurs check in the Core unifier] and (ATF13) +uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty + = go bvs ty where - go :: TyCoVarSet -- Bound by enclosing foralls + go :: TyCoVarSet -- Bound by enclosing foralls; see (OCU1) -> Type -> Bool go bvs ty | Just ty' <- coreView ty = go bvs ty' go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv @@ -1993,8 +2027,11 @@ uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`? go_tc bvs tc tys - | isTypeFamilyTyCon tc + | isEmptyVarSet bvs -- Never look up in um_fam_env under a forall (ATF3) + , isTypeFamilyTyCon tc , Just ty' <- lookupFamEnv fam_env tc (take arity tys) + -- NB: we look up /un-substituted/ types; + -- See Note [Shortcomings of the apartness test] = go bvs ty' || any (go bvs) (drop arity tys) | TyFamLHS tc' tys' <- lhs @@ -2022,6 +2059,11 @@ could lead to a loop. That is, could there by a type `s` such that It's vital that we do both at once: we might have (1) already and add (2); or we might have (2) already and add (1). +(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive + under a forall; indeed it is /unsound/ to consult it becuase we have have a binding + (F a :-> Int), and then unify (forall a. ...(F a)...) with something. We don't + want to map that (F a) to Int! + Note [Unifying coercion-foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we try to unify (forall cv. t1) ~ (forall cv. t2). ===================================== testsuite/tests/typecheck/should_compile/T26358.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeFamilies #-} + +module T26358 where +import Data.Kind +import Data.Proxy + +{- Two failing tests, described in GHC.Core.Unify + Note [Shortcomings of the apartness test] + +Explanation for TF2 +* We try to reduce + (TF2 (F (G Float)) (F Int) (G Float)) +* We can only do so if those arguments are apart from the first + equation of TF2, namely (Bool,Char,Int). +* So we try to unify + [F (G Float), F Int, G Float] ~ [Bool, Char, Int] +* They really are apart, but we can't quite spot that yet; + hence #26358 + +TF1 is similar. +-} + + +type TF1 :: Type -> Type -> Type -> Type +type family TF1 a b c where + TF1 Bool Char a = Word + TF1 a b c = (a,b,c) + +type F :: Type -> Type +type family F a where + +foo :: Proxy a + -> Proxy (TF1 (F a) (F Int) Int) + -> Proxy (F a, F Int, Int) +foo _ px = px + +type TF2 :: Type -> Type -> Type -> Type +type family TF2 a b c where + TF2 Bool Char Int = Word + TF2 a b c = (a,b,c) + +type G :: Type -> Type +type family G a where + +bar :: Proxy (TF2 (F (G Float)) (F Int) (G Float)) + -> Proxy (F (G Float), F Int, G Float) +bar px = px + ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -946,3 +946,4 @@ test('T14010', normal, compile, ['']) test('T26256a', normal, compile, ['']) test('T25992a', normal, compile, ['']) test('T26346', normal, compile, ['']) +test('T26358', expect_broken(26358), compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d194118242f03283813c7b8234399… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d194118242f03283813c7b8234399… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
by Marge Bot (＠marge-bot) 27 Aug '25

27 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - 23 changed files: - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/.gitignore - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -75,14 +75,15 @@ data UsageConfig = UsageConfig mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet - -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded + -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IfG [Usage] mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods imp_decls used_names - dependent_files merged needed_links needed_pkgs + dependent_files dependent_dirs merged needed_links needed_pkgs = do eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) - hashes <- liftIO $ mapM getFileHash dependent_files + file_hashes <- liftIO $ mapM getFileHash dependent_files + dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs let hu = ue_unsafeHomeUnit unit_env hug = ue_home_unit_graph unit_env -- Dependencies on object files due to TH and plugins @@ -93,7 +94,11 @@ mkUsageInfo uc plugins fc unit_env let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f , usg_file_hash = hash , usg_file_label = Nothing } - | (f, hash) <- zip dependent_files hashes ] + | (f, hash) <- zip dependent_files file_hashes ] + ++ [ UsageDirectory { usg_dir_path = mkFastString d + , usg_dir_hash = hash + , usg_dir_label = Nothing } + | (d, hash) <- zip dependent_dirs dirs_hashes] ++ [ UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash ===================================== compiler/GHC/Iface/Make.hs ===================================== @@ -269,6 +269,7 @@ mkRecompUsageInfo hsc_env tc_result = do else do let used_names = mkUsedNames tc_result dep_files <- (readIORef (tcg_dependent_files tc_result)) + dep_dirs <- (readIORef (tcg_dependent_dirs tc_result)) (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) let uc = initUsageConfig hsc_env plugins = hsc_plugins hsc_env @@ -289,6 +290,7 @@ mkRecompUsageInfo hsc_env tc_result = do (tcg_import_decls tc_result) used_names dep_files + dep_dirs (tcg_merged tc_result) needed_links needed_pkgs ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -194,6 +194,7 @@ data RecompReason | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName | FileChanged FilePath + | DirChanged FilePath | CustomReason String | FlagsChanged | LinkFlagsChanged @@ -230,6 +231,7 @@ instance Outputable RecompReason where ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed" ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" FileChanged fp -> text fp <+> text "changed" + DirChanged dp -> text "Contents of" <+> text dp <+> text "changed" CustomReason s -> text s FlagsChanged -> text "Flags changed" LinkFlagsChanged -> text "Flags changed" @@ -815,6 +817,22 @@ checkModUsage fc UsageFile{ usg_file_path = file, then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail +checkModUsage fc UsageDirectory{ usg_dir_path = dir, + usg_dir_hash = old_hash, + usg_dir_label = mlabel } = + liftIO $ + handleIO handler $ do + new_hash <- lookupDirCache fc $ unpackFS dir + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + reason = DirChanged $ unpackFS dir + recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel + handler = if debugIsOn + then \e -> pprTrace "UsageDirectory" (text (show e)) $ return recomp + else \_ -> return recomp -- if we can't find the dir, just recompile, don't fail + -- | We are importing a module whose exports have changed. -- Does this require recompilation? -- ===================================== compiler/GHC/Iface/Recomp/Types.hs ===================================== @@ -140,6 +140,10 @@ pprUsage usage@UsageFile{} = hsep [text "addDependentFile", doubleQuotes (ftext (usg_file_path usage)), ppr (usg_file_hash usage)] +pprUsage usage@UsageDirectory{} + = hsep [text "AddDependentDirectory", + doubleQuotes (ftext (usg_dir_path usage)), + ppr (usg_dir_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsage usage@UsageHomeModuleInterface{} ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -173,8 +173,6 @@ import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) - - {- Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1524,6 +1522,11 @@ instance TH.Quasi TcM where dep_files <- readTcRef ref writeTcRef ref (fp:dep_files) + qAddDependentDirectory dp = do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + qAddTempFile suffix = do dflags <- getDynFlags logger <- getLogger @@ -1928,6 +1931,7 @@ handleTHMessage msg = case msg of ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d AddTempFile s -> wrapTHResult $ TH.qAddTempFile s AddModFinalizer r -> do interp <- hscInterp <$> getTopEnv ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -603,6 +603,7 @@ data TcGblEnv -- decls. tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + tcg_dependent_dirs :: TcRef [FilePath], -- ^ dependencies from addDependentDirectory tcg_th_topdecls :: TcRef [LHsDecl GhcPs], -- ^ Top-level declarations from addTopDecls ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad( getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getDeclaredDefaultTys, - addDependentFiles, + addDependentFiles, addDependentDirectories, -- * Error management getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, @@ -273,6 +273,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this let { type_env_var = hsc_type_env_vars hsc_env }; dependent_files_var <- newIORef [] ; + dependent_dirs_var <- newIORef [] ; static_wc_var <- newIORef emptyWC ; cc_st_var <- newIORef newCostCentreState ; th_topdecls_var <- newIORef [] ; @@ -368,6 +369,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_safe_infer = infer_var, tcg_safe_infer_reasons = infer_reasons_var, tcg_dependent_files = dependent_files_var, + tcg_dependent_dirs = dependent_dirs_var, tcg_tc_plugin_solvers = [], tcg_tc_plugin_rewriters = emptyUFM, tcg_defaulting_plugins = [], @@ -956,6 +958,12 @@ addDependentFiles fs = do dep_files <- readTcRef ref writeTcRef ref (fs ++ dep_files) +addDependentDirectories :: [FilePath] -> TcRn () +addDependentDirectories ds = do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (ds ++ dep_dirs) + {- ************************************************************************ * * ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -31,6 +31,9 @@ module GHC.Unit.Finder ( findObjectLinkableMaybe, findObjectLinkable, + + -- important that GHC.HsToCore.Usage uses the same hashing method for usage dirs as is used here. + getDirHash, ) where import GHC.Prelude @@ -69,7 +72,9 @@ import GHC.Types.Unique.Map import GHC.Driver.Env import GHC.Driver.Config.Finder import GHC.Types.Unique.Set +import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE @@ -108,10 +113,12 @@ initFinderCache :: IO FinderCache initFinderCache = do mod_cache <- newIORef emptyInstalledModuleEnv file_cache <- newIORef M.empty + dir_cache <- newIORef M.empty let flushFinderCaches :: UnitEnv -> IO () flushFinderCaches ue = do atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) atomicModifyIORef' file_cache $ \_ -> (M.empty, ()) + atomicModifyIORef' dir_cache $ \_ -> (M.empty, ()) where is_ext mod _ = not (isUnitEnvInstalledModule ue mod) @@ -138,8 +145,27 @@ initFinderCache = do atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ()) return hash Just fp -> return fp + lookupDirCache :: FilePath -> IO Fingerprint + lookupDirCache key = do + c <- readIORef dir_cache + case M.lookup key c of + Nothing -> do + hash <- getDirHash key + atomicModifyIORef' dir_cache $ \c -> (M.insert key hash c, ()) + return hash + Just fp -> return fp return FinderCache{..} +-- | This function computes a shallow hash of a directory, so really just what files and directories are directly inside it. +-- It does not look at the contents of the files, or the contents of the directories it contains. +getDirHash :: FilePath -> IO Fingerprint +getDirHash dir = do + contents <- SD.listDirectory dir + let hashes = fingerprintString <$> contents + let s_hashes = L.sort hashes + let hash = fingerprintFingerprints s_hashes + return hash + -- ----------------------------------------------------------------------------- -- The three external entry points ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -38,6 +38,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO () , lookupFileCache :: FilePath -> IO Fingerprint -- ^ Look for the hash of a file in the cache. This should add it to the -- cache. If the file doesn't exist, raise an IOException. + , lookupDirCache :: FilePath -> IO Fingerprint } data InstalledFindResult ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -357,6 +357,23 @@ data Usage -- contents don't change. This previously lead to odd -- recompilation behaviors; see #8114 } + | UsageDirectory { + usg_dir_path :: FastString, + -- ^ External dir dependency. From TH addDependentFile. + -- Should be absolute. + usg_dir_hash :: Fingerprint, + -- ^ 'Fingerprint' of the directories contents. + + usg_dir_label :: Maybe String + -- ^ An optional string which is used in recompilation messages if + -- dir in question has changed. + + -- Note: We do a very shallow check indeed, just what the contents of + -- the directory are, aka what files and directories are within it. + -- If those files/directories have their own contents changed, then + -- we won't spot it here. If you do want to spot that, the caller + -- should recursively add them to their useage. + } | UsageHomeModuleInterface { usg_mod_name :: ModuleName -- ^ Name of the module @@ -395,6 +412,7 @@ instance NFData Usage where rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` () rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` () rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` () + rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` () rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` () rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () @@ -431,6 +449,12 @@ instance Binary Usage where put_ bh (usg_unit_id usg) put_ bh (usg_iface_hash usg) + put_ bh usg@UsageDirectory{} = do + putByte bh 5 + put_ bh (usg_dir_path usg) + put_ bh (usg_dir_hash usg) + put_ bh (usg_dir_label usg) + get bh = do h <- getByte bh case h of @@ -462,6 +486,12 @@ instance Binary Usage where uid <- get bh hash <- get bh return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } + 5 -> do + dp <- get bh + hash <- get bh + label <- get bh + return UsageDirectory { usg_dir_path = dp, usg_dir_hash = hash, usg_dir_label = label } + i -> error ("Binary.get(Usage): " ++ show i) -- | Records the imports that we depend on from a home module, ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -55,6 +55,11 @@ Cmm ``template-haskell`` library ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- We have added the ``addDependentDirectory`` function to match + ``addDependentFile``, which adds a directory to the list of dependencies that + the recompilation checker will look at to determine if a module needs to be + recompiled. + Included libraries ~~~~~~~~~~~~~~~~~~ ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -710,7 +710,7 @@ beautiful sight! You can read about :ghc-wiki:`how all this works <commentary/compiler/recompilation-avoidance>` in the GHC commentary. Recompilation for Template Haskell and Plugins -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recompilation checking gets a bit more complicated when using Template Haskell or plugins. Both these features execute code at compile time and so if any of the @@ -727,6 +727,19 @@ if ``foo`` is from module ``A`` and ``bar`` is from module ``B``, the module wil now depend on ``A.o`` and ``B.o``, if either of these change then the module will be recompiled. +``addDependentFile`` and ``addDependentDirectory`` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +When using Template Haskell or plugins, you can use the functions +``addDependentFile`` and ``addDependentDirectory`` to add additional +dependencies to the module being compiled. + +- When adding a file, this means that the contents of the file changing between + compilations will trigger a recompilation of the module. +- When adding a directory, this means that any file or subdirectory *added* to or + *removed* from the directory will trigger recompilation of the module, so + it is not a recursive dependency. + .. _mutual-recursion: Mutually recursive modules and hs-boot files ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -132,6 +132,9 @@ class (MonadIO m, MonadFail m) => Quasi m where -- | See 'addDependentFile'. qAddDependentFile :: FilePath -> m () + -- | See 'addDependentDirectory'. + qAddDependentDirectory :: FilePath -> m () + -- | See 'addTempFile'. qAddTempFile :: String -> m FilePath @@ -202,6 +205,7 @@ instance Quasi IO where qExtsEnabled = badIO "extsEnabled" qPutDoc _ _ = badIO "putDoc" qGetDoc _ = badIO "getDoc" + qAddDependentDirectory _ = badIO "AddDependentDirectory" instance Quote IO where newName = newNameIO @@ -819,6 +823,24 @@ getPackageRoot :: Q FilePath getPackageRoot = Q qGetPackageRoot +-- | Record external directories that runIO is using (dependent upon). +-- The compiler can then recognize that it should re-compile the Haskell file +-- when a directory changes. +-- +-- Notes: +-- +-- * ghc -M does not know about these dependencies - it does not execute TH. +-- +-- * The dependency is shallow, based only on the direct content. +-- Basically, it only sees a list of names. It does not look at directory +-- metadata, recurse into subdirectories, or look at file contents. As +-- long as the list of names remains the same, the directory is considered +-- unchanged. +-- +-- * The state of the directory is read at the interface generation time, +-- not at the time of the function call. +addDependentDirectory :: FilePath -> Q () +addDependentDirectory dp = Q (qAddDependentDirectory dp) -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -830,7 +852,11 @@ getPackageRoot = Q qGetPackageRoot -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- --- * The dependency is based on file content, not a modification time +-- * The dependency is based on file content, not a modification time or +-- any other metadata associated with the file (e.g. permissions). +-- +-- * The state of the file is read at the interface generation time, +-- not at the time of the function call. addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) @@ -952,32 +978,33 @@ instance MonadIO Q where liftIO = runIO instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyType = reifyType - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qGetPackageRoot = getPackageRoot - qAddDependentFile = addDependentFile - qAddTempFile = addTempFile - qAddTopDecls = addTopDecls - qAddForeignFilePath = addForeignFilePath - qAddModFinalizer = addModFinalizer - qAddCorePlugin = addCorePlugin - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - qPutDoc = putDoc - qGetDoc = getDoc + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyType = reifyType + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qGetPackageRoot = getPackageRoot + qAddDependentFile = addDependentFile + qAddDependentDirectory = addDependentDirectory + qAddTempFile = addTempFile + qAddTopDecls = addTopDecls + qAddForeignFilePath = addForeignFilePath + qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled + qPutDoc = putDoc + qGetDoc = getDoc ---------------------------------------------------- ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -291,6 +291,7 @@ data THMessage a where GetPackageRoot :: THMessage (THResult FilePath) AddDependentFile :: FilePath -> THMessage (THResult ()) + AddDependentDirectory :: FilePath -> THMessage (THResult ()) AddTempFile :: String -> THMessage (THResult FilePath) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) AddCorePlugin :: String -> THMessage (THResult ()) @@ -343,6 +344,7 @@ getTHMessage = do 23 -> THMsg <$> (PutDoc <$> get <*> get) 24 -> THMsg <$> GetDoc <$> get 25 -> THMsg <$> return GetPackageRoot + 26 -> THMsg <$> AddDependentDirectory <$> get n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put @@ -373,7 +375,7 @@ putTHMessage m = case m of PutDoc l s -> putWord8 23 >> put l >> put s GetDoc l -> putWord8 24 >> put l GetPackageRoot -> putWord8 25 - + AddDependentDirectory a -> putWord8 26 >> put a data EvalOpts = EvalOpts { useSandboxThread :: Bool ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -195,6 +195,7 @@ instance TH.Quasi GHCiQ where qLocation = fromMaybe noLoc . qsLocation <$> getState qGetPackageRoot = ghcCmd GetPackageRoot qAddDependentFile file = ghcCmd (AddDependentFile file) + qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -34,6 +34,7 @@ module Language.Haskell.TH.Syntax ( ModName (..), addCorePlugin, addDependentFile, + addDependentDirectory, addForeignFile, addForeignFilePath, addForeignSource, ===================================== testsuite/.gitignore ===================================== @@ -1523,6 +1523,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/th/T8633 /tests/th/TH_Depends /tests/th/TH_Depends_external.txt +/tests/th/TH_Depends_external/dummy.txt /tests/th/TH_StringPrimL /tests/th/TH_import_loop/ModuleA.hi-boot /tests/th/TH_import_loop/ModuleA.o-boot ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1717,6 +1717,7 @@ module Language.Haskell.TH.Syntax where qRunIO :: forall a. GHC.Internal.Types.IO a -> m a qGetPackageRoot :: m GHC.Internal.IO.FilePath qAddDependentFile :: GHC.Internal.IO.FilePath -> m () + qAddDependentDirectory :: GHC.Internal.IO.FilePath -> m () qAddTempFile :: GHC.Internal.Base.String -> m GHC.Internal.IO.FilePath qAddTopDecls :: [Dec] -> m () qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () @@ -1728,7 +1729,7 @@ module Language.Haskell.TH.Syntax where qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) - {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} + {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} type Quote :: (* -> *) -> Constraint class GHC.Internal.Base.Monad m => Quote m where newName :: GHC.Internal.Base.String -> m Name @@ -1781,6 +1782,7 @@ module Language.Haskell.TH.Syntax where type VarStrictType :: * type VarStrictType = VarBangType addCorePlugin :: GHC.Internal.Base.String -> Q () + addDependentDirectory :: GHC.Internal.IO.FilePath -> Q () addDependentFile :: GHC.Internal.IO.FilePath -> Q () addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q () addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q () ===================================== testsuite/tests/th/Makefile ===================================== @@ -43,6 +43,46 @@ TH_Depends: '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends ./TH_Depends +.PHONY: TH_Depends_Dir +TH_Depends_Dir: + rm -rf TRIGGER_RECOMP + rm -rf DONT_TRIGGER_RECOMP + $(RM) TH_Depends_Dir TH_Depends_Dir.exe + $(RM) TH_Depends_Dir.o TH_Depends_Dir.hi + $(RM) TH_Depends_Dir_External.o TH_Depends_Dir_External.hi + + mkdir TRIGGER_RECOMP + mkdir DONT_TRIGGER_RECOMP + +# First build with an empty dependent directory + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir + ./TH_Depends_Dir + +# Create a file in the dependent directory to trigger recompilation + sleep 2 + echo "dummy" > TRIGGER_RECOMP/dummy.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir + ./TH_Depends_Dir + +# Remove the file to check that recompilation is triggered + sleep 2 + $(RM) TRIGGER_RECOMP/dummy.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir + ./TH_Depends_Dir + +# Should not trigger recompilation + sleep 2 + echo "dummy" > DONT_TRIGGER_RECOMP/dummy.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir + ./TH_Depends_Dir + +# Should trigger a recompilation. Note that we should also see the change +# in the non-dependent directory now, since it is still rechecked as long +# as we recompile, it just doesn't *trigger* a recompilation. + sleep 2 + rm -rf TRIGGER_RECOMP + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir + ./TH_Depends_Dir T8333: '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(ghcThWayFlags) T8333.hs < /dev/null ===================================== testsuite/tests/th/TH_Depends_Dir.hs ===================================== @@ -0,0 +1,10 @@ + +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import TH_Depends_Dir_External (checkDirectoryContent) + +main :: IO () +main = do + print $checkDirectoryContent ===================================== testsuite/tests/th/TH_Depends_Dir.stdout ===================================== @@ -0,0 +1,5 @@ +"dependent directory is empty, non-dependent directory is empty." +"dependent directory is non-empty, non-dependent directory is empty." +"dependent directory is empty, non-dependent directory is empty." +"dependent directory is empty, non-dependent directory is empty." +"dependent directory does not exist, non-dependent directory is non-empty." ===================================== testsuite/tests/th/TH_Depends_Dir_External.hs ===================================== @@ -0,0 +1,41 @@ + +module TH_Depends_Dir_External where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib +import System.Directory (listDirectory, doesDirectoryExist) + +-- | This function checks the contents of a dependent directory and a non-dependent directory. +-- So its value will change if the contents of the dependent directory change. +-- It will not change if the contents of the non-dependent directory change. +checkDirectoryContent :: Q Exp +checkDirectoryContent = do + let dependentDir = "TRIGGER_RECOMP" + let nonDependentDir = "DONT_TRIGGER_RECOMP" + + -- this will error when dependentDir does not exist + -- which is the last thing we test for in the Makefile + exists <- qRunIO $ doesDirectoryExist dependentDir + dep_str <- if exists + then do + qAddDependentDirectory dependentDir + l <- qRunIO $ listDirectory dependentDir + case l of + [] -> pure "dependent directory is empty" + _ -> pure "dependent directory is non-empty" + else do + -- note that once we are here we no longer depend on the directory + -- so no more recompilation will happen. + pure "dependent directory does not exist" + + -- Now the part that shouldn't trigger recompilation. + -- This is somewhat of a sanity check, if we change nonDependentDir + -- and it triggers recompilation, then something must be wrong + -- with the recompilation logic. + non_deps <- qRunIO $ listDirectory nonDependentDir + non_dep_str <- case non_deps of + [] -> pure "non-dependent directory is empty." + _ -> pure "non-dependent directory is non-empty." + + -- Return the result as a string expression + stringE $ dep_str ++ ", " ++ non_dep_str ===================================== testsuite/tests/th/all.T ===================================== @@ -214,6 +214,7 @@ test('T5434', [], multimod_compile, ['T5434', '-v0 -Wall ' + config.ghc_th_way_flags]) test('T5508', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_Depends', [only_ways(['normal'])], makefile_test, ['TH_Depends']) +test('TH_Depends_Dir', [only_ways(['normal']), js_skip], makefile_test, ['TH_Depends_Dir']) test('T5597', [], multimod_compile, ['T5597', '-v0 ' + config.ghc_th_way_flags]) test('T5665', [], multimod_compile, ['T5665', '-v0 ' + config.ghc_th_way_flags]) test('T5700', [], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae89f0006cb0221e54a6bcecfb15423… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae89f0006cb0221e54a6bcecfb15423… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Import new name for 'utimbuf' on windows to fix #26337
by Marge Bot (＠marge-bot) 27 Aug '25

27 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00 Import new name for 'utimbuf' on windows to fix #26337 Fixes an `-Wincompatible-pointer-types` instance that turns into an error on recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross. This long-standing warning has been present at least since 9.4: ``` C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error: warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types] | 26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} | ^ HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);} ^~ C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error: note: passing argument to parameter '_Utimbuf' here | 109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { | ^ __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) { ``` - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -97,7 +97,11 @@ data {-# CTYPE "struct stat" #-} CStat data {-# CTYPE "struct termios" #-} CTermios data {-# CTYPE "struct tm" #-} CTm data {-# CTYPE "struct tms" #-} CTms +#if defined(mingw32_HOST_OS) +data {-# CTYPE "struct _utimbuf" #-} CUtimbuf +#else data {-# CTYPE "struct utimbuf" #-} CUtimbuf +#endif data {-# CTYPE "struct utsname" #-} CUtsname type FD = CInt View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9f2ffcf8449dea2d3639b5aba25dbc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9f2ffcf8449dea2d3639b5aba25dbc… You're receiving this email because of your account on gitlab.haskell.org.

1 0