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 ===================================== @@ -0,0 +1,24 @@ +{-# 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 ===================================== @@ -0,0 +1,2 @@ +none +some 6 ===================================== testsuite/tests/ffi/should_run/PrimFFIUnboxedSum_cmm.cmm ===================================== @@ -0,0 +1,9 @@ +#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']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cd7f742008454f4e5b9499631d3a64e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cd7f742008454f4e5b9499631d3a64e... You're receiving this email because of your account on gitlab.haskell.org.