sheaf pushed to branch wip/T23210 at Glasgow Haskell Compiler / GHC Commits: 32109d08 by sheaf at 2025-09-16T13:45:50+02:00 fixup - - - - - 6aad2058 by sheaf at 2025-09-16T13:46:22+02:00 Add test for #26216 - - - - - 6 changed files: - compiler/GHC/StgToByteCode.hs - + testsuite/tests/bytecode/T26216.hs - + testsuite/tests/bytecode/T26216.script - + testsuite/tests/bytecode/T26216.stdout - + testsuite/tests/bytecode/T26216_aux.hs - testsuite/tests/bytecode/all.T Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -2336,7 +2336,7 @@ pushAtom d p (StgVarArg var) | isNullaryRepDataCon con -> return (unitOL (PACK con 0), szb) - _ -> + _ -- see Note [Generating code for top-level string literal bindings] | idType var `eqType` addrPrimTy -> return (unitOL (PUSH_ADDR (getName var)), szb) ===================================== testsuite/tests/bytecode/T26216.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE GHC2024, BlockArguments, MagicHash #-} + +module T26216 (main) where + +import Data.Kind (Type, Constraint) +import GHC.TypeNats +import GHC.Exts (proxy#) + +import T26216_aux + +getN :: forall (n :: Nat). SNat n -> Natural +getN s = withKnownNat s (natVal s) + +type C :: forall {k}. (k -> Constraint) -> k -> Type +data C c a where { C :: c a => C c a } + +know :: forall (n :: Nat). SNat n -> C KnownNat n +know s = withKnownNat s C + +getC :: forall (n :: Nat). C KnownNat n -> Natural +getC C = natVal' (proxy# @n) + +main :: IO () +main = do + let !s = mkSome $ natSing @42 + !c = withSome s $ mkSome . know + print $ withSome s getN + print $ withSome c getC ===================================== testsuite/tests/bytecode/T26216.script ===================================== @@ -0,0 +1,2 @@ +:l T26216 +main ===================================== testsuite/tests/bytecode/T26216.stdout ===================================== @@ -0,0 +1,2 @@ +42 +42 ===================================== testsuite/tests/bytecode/T26216_aux.hs ===================================== @@ -0,0 +1,25 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} + +module T26216_aux (Some, data Some, mkSome, withSome) where +import Data.Kind (Type) +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +type Some :: (k -> Type) -> Type +newtype Some tag = UnsafeSome (tag Any) +type role Some representational + +{-# COMPLETE Some #-} +pattern Some :: tag a -> Some tag +pattern Some x <- UnsafeSome x + where Some x = UnsafeSome ((unsafeCoerce :: tag a -> tag Any) x) + +-- | Constructor. +mkSome :: tag a -> Some tag +mkSome = \x -> UnsafeSome (unsafeCoerce x) + +-- | Eliminator. +withSome :: Some tag -> (forall a. tag a -> b) -> b +withSome (UnsafeSome thing) some = some (unsafeCoerce thing) ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -5,3 +5,7 @@ test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_scr test('T25975', extra_ways(ghci_ways), compile_and_run, # Some of the examples work more robustly with these flags ['-fno-break-points -fno-full-laziness']) + +# Nullary data constructors +test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/521b9264f9e131ed7c8e8d17c41fde1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/521b9264f9e131ed7c8e8d17c41fde1... You're receiving this email because of your account on gitlab.haskell.org.