GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

d57f01a4

by Matthew Pickering at 2026-03-11T15:08:40-04:00

testsuite: Add test for foreign import prim with unboxed tuple return

This commit just adds a test that foreign import prim works with unboxed
sums.

23d111ce

by Matthew Pickering at 2026-03-11T15:08:41-04:00

Return a valid pointer in advanceStackFrameLocationzh

When there is no next stack chunk, `advanceStackFrameLocationzh` used to
return NULL in the pointer-typed StackSnapshot# result slot.

Even though the caller treats that case as "no next frame", the result is
still materialized in a GC-visible pointer slot. If a GC observes the raw
NULL there, stack decoding can crash.

Fix this by ensuring the dead pointer slot contains a valid closure
pointer. Also make the optional result explicit by returning an unboxed
sum instead of a tuple with a separate tag.

Fixes #27009

6 changed files:

libraries/ghc-internal/cbits/Stack.cmm
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
+ testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.hs
+ testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.stdout
+ testsuite/tests/ffi/should_run/PrimFFIUnboxedSum_cmm.cmm
testsuite/tests/ffi/should_run/all.T

Changes:

libraries/ghc-internal/cbits/Stack.cmm

@@ -8,9 +8,11 @@
  // developed.
  #if defined(StgStack_marking)
 -// Returns the next stackframe's StgStack* and offset in it. And, an indicator
 -// if this frame is the last one (`hasNext` bit.)
 -// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
 +// Returns the next stackframe location as
 +//   (# (# #) | (# StgStack*, StgWord #) #)
 +// flattened to its runtime representation:
 +//   (tag, StgStack*, StgWord)
 +// where tag 1 means no next frame and tag 2 means the payload is present.
  advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
    W_ frameSize;
    (frameSize) = ccall stackFrameSize(stack, offsetWords);
@@ -27,27 +29,30 @@ advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
    stackSizeInBytes = WDS(stackSize);
    stackBottom = stackSizeInBytes + stackArrayPtr;
 +  W_ tag, newOffsetWords;
    P_ newStack;
 -  W_ newOffsetWords, hasNext;
    if(nextClosurePtr < stackBottom) (likely: True) {
 +    tag = 2;
      newStack = stack;
      newOffsetWords = offsetWords + frameSize;
 -    hasNext = 1;
    } else {
      P_ underflowFrameStack;
      (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
      if (underflowFrameStack == NULL) (likely: True) {
 -      newStack = NULL;
 -      newOffsetWords = NULL;
 -      hasNext = NULL;
 +      // The empty alternative still has dead payload slots in the flattened
 +      // sum representation, so the pointer field must contain a valid closure
 +      // pointer rather than NULL.
 +      tag = 1;
 +      newStack = stack;
 +      newOffsetWords = 0;
      } else {
 +      tag = 2;
        newStack = underflowFrameStack;
 -      newOffsetWords = NULL;
 -      hasNext = 1;
 +      newOffsetWords = 0;
+     }
+   }
 -  return (newStack, newOffsetWords, hasNext);
 +  return (tag, newStack, newOffsetWords);
+ }
  // (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)

libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs

@@ -11,6 +11,7 @@
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeInType #-}
  {-# LANGUAGE UnboxedTuples #-}
 +{-# LANGUAGE UnboxedSums #-}
  {-# LANGUAGE UnliftedFFITypes #-}
  module GHC.Internal.Stack.Decode (
@@ -214,21 +215,19 @@ getStackFields stackSnapshot# =
  stackHead :: StackSnapshot# -> StackFrameLocation
  stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty
 --- | Advance to the next stack frame (if any)
 ---
 --- The last `Int#` in the result tuple is meant to be treated as bool
 --- (has_next).
 +-- | Advance to the next stack frame (if any).
  foreign import prim "advanceStackFrameLocationzh"
    advanceStackFrameLocation# ::
 -    StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
 +    StackSnapshot# -> Word# -> (# (# #) | (# StackSnapshot#, Word# #) #)
  -- | Advance to the next stack frame (if any)
  advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
  advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
 -  let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)
 -   in if I# hasNext > 0
 -        then Just (StackSnapshot s', primWordToWordOffset i')
 -        else Nothing
 +  case advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) of
 +    (# (# #) | #) ->
 +      Nothing
 +    (# | (# s', i' #) #) ->
 +      Just (StackSnapshot s', primWordToWordOffset i')
    where
      primWordToWordOffset :: Word# -> WordOffset
      primWordToWordOffset w# = fromIntegral (W# w#)

testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.hs

 +{-# LANGUAGE GHCForeignImportPrim #-}
 +{-# LANGUAGE MagicHash #-}
 +{-# LANGUAGE UnboxedTuples #-}
 +{-# LANGUAGE UnboxedSums #-}
 +{-# LANGUAGE UnliftedFFITypes #-}
++
 +module Main where
++
 +import GHC.Exts
 +import GHC.Word
++
 +foreign import prim "sumWord"
 +  sumWord# :: Word# -> (# (# #) | Word# #)
++
 +render :: Word# -> String
 +render w# =
 +  case sumWord# w# of
 +    (# (# #) | #) -> "none"
 +    (# | r# #) -> "some " ++ show (W# r#)
++
 +main :: IO ()
 +main = do
 +  putStrLn (render 0##)
 +  putStrLn (render 5##)

testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.stdout

	1	+none
	2	+some 6

testsuite/tests/ffi/should_run/PrimFFIUnboxedSum_cmm.cmm

 +#include "Cmm.h"
++
 +sumWord(W_ w) {
 +  if (w == 0) {
 +    return (1, 0);
 +  } else {
 +    return (2, w + 1);
 +  }
 +}

testsuite/tests/ffi/should_run/all.T

@@ -225,6 +225,8 @@ test('PrimFFIInt32', [req_c], compile_and_run, ['PrimFFIInt32_c.c'])
  test('PrimFFIWord32', [req_c], compile_and_run, ['PrimFFIWord32_c.c'])
 +test('PrimFFIUnboxedSum', req_cmm, compile_and_run, ['PrimFFIUnboxedSum_cmm.cmm'])
++
  test('T493', [ req_c], compile_and_run, ['T493_c.c'])
  test('UnliftedNewtypesByteArrayOffset', [req_c], compile_and_run, ['UnliftedNewtypesByteArrayOffset_c.c'])