[Git][ghc/ghc][master] Fix bad bug in mkSynonymTyCon, re forgetfulness
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jul 24 06:41:36 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
55117e13 by Simon Peyton Jones at 2024-07-24T02:41:12-04:00
Fix bad bug in mkSynonymTyCon, re forgetfulness
As #25094 showed, the previous tests for forgetfulness was
plain wrong, when there was a forgetful synonym in the RHS
of a synonym.
- - - - -
3 changed files:
- compiler/GHC/Core/Type.hs
- + testsuite/tests/typecheck/should_compile/T25094.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2315,22 +2315,27 @@ buildSynTyCon name binders res_kind roles rhs
where
is_tau = isTauTy rhs
is_fam_free = isFamFreeTy rhs
+ expanded_rhs = expandTypeSynonyms rhs
+
is_concrete = uniqSetAll isConcreteTyCon rhs_tycons
- -- NB: is_concrete is allowed to be conservative, returning False
- -- more often than it could. e.g.
+ rhs_tycons = tyConsOfType expanded_rhs
+ -- NB: we look at expanded_rhs e.g.
-- type S a b = b
-- type family F a
-- type T a = S (F a) a
- -- We will mark T as not-concrete, even though (since S ignore its first
- -- argument, it could be marked concrete.
-
- is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) ||
- uniqSetAny isForgetfulSynTyCon rhs_tycons
- -- NB: is_forgetful is allowed to be conservative, returning True more often
- -- than it should. See Note [Forgetful type synonyms] in GHC.Core.TyCon
-
- rhs_tycons = tyConsOfType rhs
- rhs_tyvars = tyCoVarsOfType rhs
+ -- We want to mark T as concrete, because S ignores its first argument
+
+ is_forgetful = not (all ((`elemVarSet` expanded_rhs_tyvars) . binderVar) binders)
+ expanded_rhs_tyvars = tyCoVarsOfType expanded_rhs
+ -- See Note [Forgetful type synonyms] in GHC.Core.TyCon
+ -- To find out if this TyCon is forgetful, expand the synonyms in its RHS
+ -- and check that all of the binders are free in the expanded type.
+ -- We really only need to expand the /forgetful/ synonyms on the RHS,
+ -- but we don't currently have a function to do that.
+ -- Failing to expand the RHS led to #25094, e.g.
+ -- type Bucket a b c = Key (a,b,c)
+ -- type Key x = Any
+ -- Here Bucket is definitely forgetful!
{-
************************************************************************
=====================================
testsuite/tests/typecheck/should_compile/T25094.hs
=====================================
@@ -0,0 +1,98 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+
+module T29054 where
+
+
+------------------------------------------------------------------------------
+import Control.Monad.ST (ST)
+import Data.Maybe (fromMaybe)
+import Data.STRef
+import GHC.Exts (Any, reallyUnsafePtrEquality#, (==#), isTrue#)
+import Unsafe.Coerce
+import Control.Monad.ST
+
+data MutableArray s a = MutableArray
+
+newArray :: Int -> a -> ST s (MutableArray s a)
+newArray = undefined
+
+readArray :: MutableArray s a -> Int -> ST s a
+readArray = undefined
+
+writeArray :: MutableArray s a -> Int -> a -> ST s ()
+writeArray = undefined
+
+
+type Key a = Any
+
+------------------------------------------------------------------------------
+-- Type signatures
+emptyRecord :: Key a
+deletedRecord :: Key a
+keyIsEmpty :: Key a -> Bool
+toKey :: a -> Key a
+fromKey :: Key a -> a
+
+
+data TombStone = EmptyElement
+ | DeletedElement
+
+{-# NOINLINE emptyRecord #-}
+emptyRecord = unsafeCoerce EmptyElement
+
+{-# NOINLINE deletedRecord #-}
+deletedRecord = unsafeCoerce DeletedElement
+
+{-# INLINE keyIsEmpty #-}
+keyIsEmpty a = isTrue# (x# ==# 1#)
+ where
+ !x# = reallyUnsafePtrEquality# a emptyRecord
+
+{-# INLINE toKey #-}
+toKey = unsafeCoerce
+
+{-# INLINE fromKey #-}
+fromKey = unsafeCoerce
+
+
+type Bucket s k v = Key (Bucket_ s k v)
+
+------------------------------------------------------------------------------
+data Bucket_ s k v = Bucket { _bucketSize :: {-# UNPACK #-} !Int
+ , _highwater :: {-# UNPACK #-} !(STRef s Int)
+ , _keys :: {-# UNPACK #-} !(MutableArray s k)
+ , _values :: {-# UNPACK #-} !(MutableArray s v)
+ }
+
+
+------------------------------------------------------------------------------
+emptyWithSize :: Int -> ST s (Bucket s k v)
+emptyWithSize !sz = undefined
+
+------------------------------------------------------------------------------
+expandArray :: a -- ^ default value
+ -> Int -- ^ new size
+ -> Int -- ^ number of elements to copy
+ -> MutableArray s a -- ^ old array
+ -> ST s (MutableArray s a)
+expandArray def !sz !hw !arr = undefined
+
+------------------------------------------------------------------------------
+growBucketTo :: Int -> Bucket s k v -> ST s (Bucket s k v)
+growBucketTo !sz bk | keyIsEmpty bk = emptyWithSize sz
+ | otherwise = do
+ if osz >= sz
+ then return bk
+ else do
+ hw <- readSTRef hwRef
+ k' <- expandArray undefined sz hw keys
+ v' <- expandArray undefined sz hw values
+ return $ toKey $ Bucket sz hwRef k' v'
+
+ where
+ bucket = fromKey bk
+ osz = _bucketSize bucket
+ hwRef = _highwater bucket
+ keys = _keys bucket
+ values = _values bucket
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -919,4 +919,4 @@ test('T23739a', normal, compile, [''])
test('T24810', normal, compile, [''])
test('T24887', normal, compile, [''])
test('T24938a', normal, compile, [''])
-
+test('T25094', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55117e13765f2fc2a8b01a377433553c5fd29719
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55117e13765f2fc2a8b01a377433553c5fd29719
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240724/53c60b4c/attachment-0001.html>
More information about the ghc-commits
mailing list