Runtime behavior of `structs` library changes with GHC 9.6.1-alpha1
Running the test suite of the structs
library on Hackage fails with GHC 9.6.1-alpha1, which does not happen with earlier versions of GHC. I've minimized the phenomenon to this standalone reproducer:
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import Control.Monad.ST
import Data.Coerce
import GHC.Exts
import GHC.ST
newtype LinkedList a s = LinkedList (Object s)
instance Struct (LinkedList a) where
struct = Dict
instance Eq (LinkedList a s) where
(==) = eqStruct
val :: forall a. Field (LinkedList a) a
val = field 0
{-# INLINE val #-}
next :: forall a. Slot (LinkedList a) (LinkedList a)
next = slot 1
{-# INLINE next #-}
newLinkedList ::
forall a. forall m.
PrimMonad m =>
a -> LinkedList a (PrimState m) -> m (LinkedList a (PrimState m))
newLinkedList val' next'
= st
(do this <- allocLinkedList
((setField val) this) val'
((set next) this) next'
return this)
allocLinkedList ::
forall a. forall m. PrimMonad m => m (LinkedList a (PrimState m))
allocLinkedList = alloc 2
{-# INLINE allocLinkedList #-}
-- Make an empty linked list
mkEmptyLinkedList :: LinkedList a s
mkEmptyLinkedList = Nil
-- Make a linked list node with a value
mkLinkedListNode :: PrimMonad m => a -> m (LinkedList a (PrimState m))
mkLinkedListNode a = newLinkedList a Nil
-- Convert a haskell list to a linked list
listToLinkedList :: PrimMonad m => [a] -> m (LinkedList a (PrimState m))
listToLinkedList [] = return mkEmptyLinkedList
listToLinkedList (x:xs) = do
head' <- mkLinkedListNode x
rest <- listToLinkedList xs
set next head' rest
return head'
main :: IO ()
main = print $ runST $ do
let xs :: [Int]
xs = []
lxs <- listToLinkedList xs
listEqLinkedList xs lxs
-- Return if a list equal to some linked list representation.
listEqLinkedList :: PrimMonad m => Eq a => [a] -> LinkedList a (PrimState m) -> m Bool
listEqLinkedList [] l = return $ isNil l
listEqLinkedList (x:xs) l = do
xval <- getField val l
if xval == x
then do
l' <- get next l
listEqLinkedList xs l'
else return False
-----
-- Control.Monad.Primitive
-----
class Monad m => PrimMonad m where
type PrimState m
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
class PrimMonad m => PrimBase m where
internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
instance PrimMonad (ST s) where
type PrimState (ST s) = s
primitive = ST
{-# INLINE primitive #-}
instance PrimBase (ST s) where
internal (ST p) = p
{-# INLINE internal #-}
primitive_ :: PrimMonad m
=> (State# (PrimState m) -> State# (PrimState m)) -> m ()
{-# INLINE primitive_ #-}
primitive_ f = primitive (\s# ->
case f s# of
s'# -> (# s'#, () #))
primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
=> m1 a -> m2 a
{-# INLINE primToPrim #-}
primToPrim m = primitive (internal m)
-----
-- Data.Struct.Internal
-----
data Dict p where
Dict :: p => Dict p
st :: PrimMonad m => ST (PrimState m) a -> m a
st = primToPrim
{-# INLINE[0] st #-}
class Struct t where
struct :: Dict (Coercible (t s) (Object s))
data Object s = Object { runObject :: SmallMutableArray# s Any }
coerceF :: Dict (Coercible a b) -> a -> b
coerceF Dict = coerce
{-# INLINE coerceF #-}
coerceB :: Dict (Coercible a b) -> b -> a
coerceB Dict = coerce
{-# INLINE coerceB #-}
destruct :: Struct t => t s -> SmallMutableArray# s Any
destruct = \x -> runObject (coerceF struct x)
{-# INLINE destruct #-}
construct :: Struct t => SmallMutableArray# s Any -> t s
construct = \x -> coerceB struct (Object x)
{-# INLINE construct #-}
eqStruct :: Struct t => t s -> t s -> Bool
eqStruct = \x y -> isTrue# (destruct x `sameSmallMutableArray#` destruct y)
{-# INLINE eqStruct #-}
alloc :: (PrimMonad m, Struct t) => Int -> m (t (PrimState m))
alloc (I# n#) = primitive $ \s -> case newSmallArray# n# undefined s of (# s', b #) -> (# s', construct b #)
writeSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> State# s -> State# s
writeSmallMutableArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s
{-# INLINE writeSmallMutableArraySmallArray# #-}
readSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, SmallMutableArray# s Any #)
readSmallMutableArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s
{-# INLINE readSmallMutableArraySmallArray# #-}
casSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #)
casSmallMutableArraySmallArray# m i o n s = unsafeCoerce# casSmallArray# m i o n s
{-# INLINE casSmallMutableArraySmallArray# #-}
data Slot x y = Slot
(forall s. SmallMutableArray# s Any -> State# s -> (# State# s, SmallMutableArray# s Any #))
(forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> State# s)
(forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #))
slot :: Int {- ^ slot -} -> Slot s t
slot (I# i) = Slot
(\m s -> readSmallMutableArraySmallArray# m i s)
(\m a s -> writeSmallMutableArraySmallArray# m i a s)
(\m o n s -> casSmallMutableArraySmallArray# m i o n s)
get :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> m (y (PrimState m))
get (Slot go _ _) = \x -> primitive $ \s -> case go (destruct x) s of
(# s', y #) -> (# s', construct y #)
{-# INLINE get #-}
set :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set (Slot _ go _) = \x y -> primitive_ (go (destruct x) (destruct y))
{-# INLINE set #-}
data Field x a = Field
(forall s. SmallMutableArray# s Any -> State# s -> (# State# s, a #)) -- get
(forall s. SmallMutableArray# s Any -> a -> State# s -> State# s) -- set
field :: Int {- ^ slot -} -> Field s a
field (I# i) = Field
(\m s -> unsafeCoerce# readSmallArray# m i s)
(\m a s -> unsafeCoerce# writeSmallArray# m i a s)
{-# INLINE field #-}
getField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> m a
getField (Field go _) = \x -> primitive (go (destruct x))
{-# INLINE getField #-}
setField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> a -> m ()
setField (Field _ go) = \x y -> primitive_ (go (destruct x) y)
{-# INLINE setField #-}
data Box = Box Null
data Null = Null
isNil :: Struct t => t s -> Bool
isNil t = isTrue# (unsafeCoerce# reallyUnsafePtrEquality# (destruct t) Null)
{-# INLINE isNil #-}
pattern Nil :: Struct t => () => t s
pattern Nil <- (isNil -> True) where
Nil = unsafeCoerce# Box Null
The intended behavior is that this program should print True
. GHC 9.4.4 does this:
$ ghc-9.4.4 Bug.hs -O -fforce-recomp
[1 of 2] Compiling Main ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]
$ ./Bug
True
But GHC 9.6.1-alpha1 prints False
instead:
$ ghc-9.6.0.20230111 Bug.hs -O -fforce-recomp
[1 of 2] Compiling Main ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]
$ ./Bug
False
A couple of observations:
- Is this code's behavior well defined? Admittedly, it is a rather advanced Edward Kmett library that makes heavy use of
unsafeCoerce#
andreallyUnsafePointerEquality#
. (See also #12669.) Still, the behavior of this library has remained remarkably stable for several GHC releases, so I figured that a change in behavior is probably worth looking into. - Speaking of
reallyUnsafePointerEquality#
, there have been some changes surrounding this function in #17126 (closed) and #20863. I'm unclear if these changes are responsible for the change in behavior seen above.