sheaf pushed to branch wip/T23210 at Glasgow Haskell Compiler / GHC
Commits:
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:
| ... | ... | @@ -2336,7 +2336,7 @@ pushAtom d p (StgVarArg var) |
| 2336 | 2336 | | isNullaryRepDataCon con ->
|
| 2337 | 2337 | return (unitOL (PACK con 0), szb)
|
| 2338 | 2338 | |
| 2339 | - _ ->
|
|
| 2339 | + _
|
|
| 2340 | 2340 | -- see Note [Generating code for top-level string literal bindings]
|
| 2341 | 2341 | | idType var `eqType` addrPrimTy ->
|
| 2342 | 2342 | return (unitOL (PUSH_ADDR (getName var)), szb)
|
| 1 | +{-# LANGUAGE GHC2024, BlockArguments, MagicHash #-}
|
|
| 2 | + |
|
| 3 | +module T26216 (main) where
|
|
| 4 | + |
|
| 5 | +import Data.Kind (Type, Constraint)
|
|
| 6 | +import GHC.TypeNats
|
|
| 7 | +import GHC.Exts (proxy#)
|
|
| 8 | + |
|
| 9 | +import T26216_aux
|
|
| 10 | + |
|
| 11 | +getN :: forall (n :: Nat). SNat n -> Natural
|
|
| 12 | +getN s = withKnownNat s (natVal s)
|
|
| 13 | + |
|
| 14 | +type C :: forall {k}. (k -> Constraint) -> k -> Type
|
|
| 15 | +data C c a where { C :: c a => C c a }
|
|
| 16 | + |
|
| 17 | +know :: forall (n :: Nat). SNat n -> C KnownNat n
|
|
| 18 | +know s = withKnownNat s C
|
|
| 19 | + |
|
| 20 | +getC :: forall (n :: Nat). C KnownNat n -> Natural
|
|
| 21 | +getC C = natVal' (proxy# @n)
|
|
| 22 | + |
|
| 23 | +main :: IO ()
|
|
| 24 | +main = do
|
|
| 25 | + let !s = mkSome $ natSing @42
|
|
| 26 | + !c = withSome s $ mkSome . know
|
|
| 27 | + print $ withSome s getN
|
|
| 28 | + print $ withSome c getC |
| 1 | +:l T26216
|
|
| 2 | +main |
| 1 | +42
|
|
| 2 | +42 |
| 1 | +{-# LANGUAGE GHC2024 #-}
|
|
| 2 | +{-# LANGUAGE PatternSynonyms #-}
|
|
| 3 | +{-# LANGUAGE PolyKinds #-}
|
|
| 4 | + |
|
| 5 | +module T26216_aux (Some, data Some, mkSome, withSome) where
|
|
| 6 | +import Data.Kind (Type)
|
|
| 7 | +import GHC.Exts (Any)
|
|
| 8 | +import Unsafe.Coerce (unsafeCoerce)
|
|
| 9 | + |
|
| 10 | +type Some :: (k -> Type) -> Type
|
|
| 11 | +newtype Some tag = UnsafeSome (tag Any)
|
|
| 12 | +type role Some representational
|
|
| 13 | + |
|
| 14 | +{-# COMPLETE Some #-}
|
|
| 15 | +pattern Some :: tag a -> Some tag
|
|
| 16 | +pattern Some x <- UnsafeSome x
|
|
| 17 | + where Some x = UnsafeSome ((unsafeCoerce :: tag a -> tag Any) x)
|
|
| 18 | + |
|
| 19 | +-- | Constructor.
|
|
| 20 | +mkSome :: tag a -> Some tag
|
|
| 21 | +mkSome = \x -> UnsafeSome (unsafeCoerce x)
|
|
| 22 | + |
|
| 23 | +-- | Eliminator.
|
|
| 24 | +withSome :: Some tag -> (forall a. tag a -> b) -> b
|
|
| 25 | +withSome (UnsafeSome thing) some = some (unsafeCoerce thing) |
| ... | ... | @@ -5,3 +5,7 @@ test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_scr |
| 5 | 5 | test('T25975', extra_ways(ghci_ways), compile_and_run,
|
| 6 | 6 | # Some of the examples work more robustly with these flags
|
| 7 | 7 | ['-fno-break-points -fno-full-laziness'])
|
| 8 | + |
|
| 9 | +# Nullary data constructors
|
|
| 10 | +test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script'])
|
|
| 11 | + |