GitLab

sheaf pushed to branch wip/T23210 at Glasgow Haskell Compiler / GHC

Commits:

4af4f0f0

by Ben Gamari at 2025-09-16T13:47:14+02:00

StgToByteCode: Don't assume that data con workers are nullary

Previously StgToByteCode assumed that all data-con workers were of a
nullary representation. This is not a valid assumption, as seen
in #23210, where an unsaturated application of a unary data
constructor's worker resulted in invalid bytecode. Sadly, I have not yet
been able to reduce a minimal testcase for this.

Fixes #23210.

6ad43bab
by Ben Gamari at 2025-09-16T13:47:14+02:00
```
testsuite: Mark T23146* as unbroken
```
baf9e13a
by sheaf at 2025-09-16T13:47:14+02:00
```
Add test for #26216
```

8 changed files:

compiler/GHC/StgToByteCode.hs
rts/Interpreter.c
+ 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
testsuite/tests/codeGen/should_run/T23146/all.T

Changes:

compiler/GHC/StgToByteCode.hs

@@ -2331,11 +2331,12 @@ pushAtom d p (StgVarArg var)
          -- PUSH_G doesn't tag constructors. So we use PACK here
          -- if we are dealing with nullary constructor.
          case isDataConWorkId_maybe var of
 -          Just con -> do
 -            massert (isNullaryRepDataCon con)
 -            return (unitOL (PACK con 0), szb)
 +          Just con
 +            -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make.
 +            | isNullaryRepDataCon con ->
 +              return (unitOL (PACK con 0), szb)
 -          Nothing
 +          _
              -- see Note [Generating code for top-level string literal bindings]
              | idType var `eqType` addrPrimTy ->
                return (unitOL (PUSH_ADDR (getName var)), szb)

rts/Interpreter.c

@@ -2227,7 +2227,6 @@ run_BCO:
              // n_nptrs=1, n_ptrs=0.
              ASSERT(n_ptrs + n_nptrs == n_words || (n_nptrs == 1 && n_ptrs == 0));
              ASSERT(n_ptrs + n_nptrs > 0);
 -            //ASSERT(n_words > 0); // We shouldn't ever need to allocate nullary constructors
              for (W_ i = 0; i < n_words; i++) {
                  con->payload[i] = (StgClosure*)ReadSpW(i);
+             }

testsuite/tests/bytecode/T26216.hs

 +{-# 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

	1	+:l T26216
	2	+main

testsuite/tests/bytecode/T26216.stdout

	1	+42
	2	+42

testsuite/tests/bytecode/T26216_aux.hs

 +{-# 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'])
++

testsuite/tests/codeGen/should_run/T23146/all.T

  test('T23146', normal, compile_and_run, [''])
  test('T23146_lifted', normal, compile_and_run, [''])
 -test('T23146_liftedeq', expect_broken_for(23060, ghci_ways), compile_and_run, [''])
 +test('T23146_liftedeq', normal, compile_and_run, [''])
  test('T23146_lifted_unlifted', normal, compile_and_run, [''])