[Git][ghc/ghc][wip/revert-type-faster] Add test for T25094

[Matthew Pickering (@mpickering)]

Matthew Pickering pushed to branch wip/revert-type-faster at Glasgow Haskell Compiler / GHC


Commits:
557235ae by Matthew Pickering at 2024-07-19T16:10:39+01:00
Add test for T25094

This test is minimised from hashtables library, before the revert it
fails with:

```
T25094.hs:84:18: warning:
    Type of case alternatives not the same as the annotation on case:
        Actual type: ST s_a12L (Bucket s_a12L Any Any)
        Annotation on case: ST s_a12L (Bucket s_a12L k_a12M v_a12N)
```

See #25094

- - - - -


2 changed files:

- + testsuite/tests/deSugar/should_compile/T25094.hs
- testsuite/tests/deSugar/should_compile/all.T


Changes:

=====================================
testsuite/tests/deSugar/should_compile/T25094.hs
=====================================
@@ -0,0 +1,99 @@
+{-# 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/deSugar/should_compile/all.T
=====================================
@@ -115,3 +115,4 @@ test('T19883', normal, compile, [''])
 test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
 test('T23550', normal, compile, [''])
 test('T24489', normal, compile, ['-O'])
+test('T25094', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/557235aebd004bc728009415e3833dba00270f75

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/557235aebd004bc728009415e3833dba00270f75
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/20240719/e1830bef/attachment-0001.html>