October 2025 - ghc-commits

[Git][ghc/ghc][master] 5 commits: Move code-gen aux symbols from ghc-internal to rts
by Marge Bot (＠marge-bot) 19 Oct '25

19 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ba3e5bdd by Rodrigo Mesquita at 2025-10-18T16:57:18-04:00 Move code-gen aux symbols from ghc-internal to rts These symbols were all previously defined in ghc-internal and made the dependency structure awkward, where the rts may refer to some of these symbols and had to work around that circular dependency the way described in #26166. Moreover, the code generator will produce code that uses these symbols! Therefore, they should be available in the rts: PRINCIPLE: If the code generator may produce code which uses this symbol, then it should be defined in the rts rather than, say, ghc-internal. That said, the main motivation is towards fixing #26166. Towards #26166. Pre-requisite of !14892 - - - - - f31de2a9 by Ben Gamari at 2025-10-18T16:57:18-04:00 rts: Avoid static symbol references to ghc-internal This resolves #26166, a bug due to new constraints placed by Apple's linker on undefined references. One source of such references in the RTS is the many symbols referenced in ghc-internal. To mitigate #26166, we make these references dynamic, as described in Note [RTS/ghc-internal interface]. Fixes #26166 Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 43fdfddc by Ben Gamari at 2025-10-18T16:57:18-04:00 compiler: Rename isMathFun -> isLibcFun This set includes more than just math functions. - - - - - 4ed5138f by Ben Gamari at 2025-10-18T16:57:18-04:00 compiler: Add libc allocator functions to libc_funs Prototypes for these are now visible from `Prim.h`, resulting in multiple-declaration warnings in the unregisterised job. - - - - - 9a0a076b by Ben Gamari at 2025-10-18T16:57:18-04:00 rts: Minimize header dependencies of Prim.h Otherwise we will end up with redundant and incompatible declarations resulting in warnings during the unregisterised build. - - - - - 52 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToC.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Linker/Static.hs - hadrian/src/Settings/Packages.hs - + libraries/ghc-internal/cbits/RtsIface.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/include/RtsIfaceSymbols.h - rts/BuiltinClosures.c - rts/CloneStack.h - rts/Compact.cmm - rts/ContinuationOps.cmm - rts/Exception.cmm - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsAPI.c - rts/RtsStartup.c - rts/RtsSymbols.c - + rts/RtsToHsIface.c - rts/StgStdThunks.cmm - rts/configure.ac - − rts/external-symbols.list.in - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - + rts/include/rts/RtsToHsIface.h - rts/include/rts/Types.h - rts/include/stg/Prim.h - rts/posix/Signals.c - libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c - libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c - libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c - libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c - libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c - libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c - libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c - libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c - libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c - libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c - libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c - libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c - libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c - − rts/rts.buildinfo.in - rts/rts.cabal - rts/wasm/JSFFI.c - rts/wasm/scheduler.cmm - rts/win32/libHSghc-internal.def - utils/deriveConstants/Main.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c85c845dc5ad539bf28f1b8c5c1dbb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c85c845dc5ad539bf28f1b8c5c1dbb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/revert-backtrace-decoder] 3 commits: Revert "Remove stg_decodeStackzh"
by Hannes Siebenhandl (＠fendor) 19 Oct '25

19 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC Commits: 7f2e764c by Fendor at 2025-10-18T20:30:18+02:00 Revert "Remove stg_decodeStackzh" This reverts commit e0544cc8a9d152c57f35bdd5e940020cc3953489. - - - - - afa0e0a0 by fendor at 2025-10-18T20:30:25+02:00 Revert "Implement `decode` in terms of `decodeStackWithIpe`" This reverts commit bd80bb7013b1c2446557a56779c88e7ad1a06259. - - - - - c3606aa3 by fendor at 2025-10-18T21:44:16+02:00 Add regression test for #26507 - - - - - 18 changed files: - libraries/base/src/GHC/Stack/CloneStack.hs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - + libraries/ghc-internal/tests/backtraces/T26507.stderr - libraries/ghc-internal/tests/backtraces/all.T - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== libraries/base/src/GHC/Stack/CloneStack.hs ===================================== @@ -17,4 +17,3 @@ module GHC.Stack.CloneStack ( ) where import GHC.Internal.Stack.CloneStack -import GHC.Internal.Stack.Decode ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrszh(P_ stack, W_ offsetWords) { - P_ p, info_struct, info_ptr_ipe_key; +// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrzh(P_ stack, W_ offsetWords) { + P_ p, info; p = StgStack_sp(stack) + WDS(offsetWords); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); - info_struct = %GET_STD_INFO(UNTAG(p)); - info_ptr_ipe_key = %INFO_PTR(UNTAG(p)); - return (info_struct, info_ptr_ipe_key); + info = %GET_STD_INFO(UNTAG(p)); + + return (info); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-internal/cbits/StackCloningDecoding.cmm ===================================== @@ -17,3 +17,10 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { return (); } + +stg_decodeStackzh (gcptr stgStack) { + gcptr stackEntries; + ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); + + return (stackEntries); +} ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) { const StgInfoTable *getItbl(StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); return get_itbl(closure); -} +}; StgWord getBitmapSize(StgClosure *c) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); ===================================== libraries/ghc-internal/jsbits/base.js ===================================== @@ -1245,21 +1245,9 @@ function h$mkdir(path, path_offset, mode) { // It is required by Google Closure Compiler to be at least defined if // somewhere it is used -var h$stg_cloneMyStackzh, - h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh, - h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh, - h$isArgGenBigRetFunTypezh, - h$getUnderflowFrameNextChunkzh, - h$getInfoTableAddrszh, - h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh +var h$stg_cloneMyStackzh, h$stg_decodeStackzh h$stg_cloneMyStackzh - = h$advanceStackFrameLocationzh - = h$getStackFieldszh = h$getStackClosurezh - = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh - = h$isArgGenBigRetFunTypezh - = h$getUnderflowFrameNextChunkzh - = h$getInfoTableAddrszh - = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh + = h$stg_decodeStackzh = function () { throw new Error('Stack Cloning Decoding: Not Implemented Yet') } ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -16,7 +16,6 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack -import qualified GHC.Internal.Stack.Decode as CloneStack import qualified GHC.Internal.Stack.CCS as CCS -- | How to collect a backtrace when an exception is thrown. @@ -144,7 +143,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe + displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs ===================================== @@ -15,20 +15,34 @@ -- @since base-4.17.0.0 module GHC.Internal.Stack.CloneStack ( StackSnapshot(..), + StackEntry(..), cloneMyStack, cloneThreadStack, + decode, + prettyStackEntry ) where import GHC.Internal.MVar +import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Base +import GHC.Internal.Foreign.Storable import GHC.Internal.Conc.Sync +import GHC.Internal.IO (unsafeInterleaveIO) +import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable) +import GHC.Internal.Num +import GHC.Internal.Real (div) import GHC.Internal.Stable +import GHC.Internal.Text.Show +import GHC.Internal.Ptr +import GHC.Internal.ClosureTypes -- | A frozen snapshot of the state of an execution stack. -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #) + foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #) @@ -191,3 +205,64 @@ cloneThreadStack (ThreadId tid#) = do IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #) freeStablePtr boxedPtr takeMVar resultVar + +-- | Representation for the source location where a return frame was pushed on the stack. +-- This happens every time when a @case ... of@ scrutinee is evaluated. +data StackEntry = StackEntry + { functionName :: String, + moduleName :: String, + srcLoc :: String, + closureType :: ClosureType + } + deriving (Show, Eq) + +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). +-- The stack trace is created from return frames with according 'InfoProvEnt' +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are +-- no 'InfoProvEnt' entries, an empty list is returned. +-- +-- Please note: +-- +-- * To gather 'StackEntry' from libraries, these have to be +-- compiled with @-finfo-table-map@, too. +-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change +-- with different GHC parameters and versions. +-- * The stack trace is empty (by design) if there are no return frames on +-- the stack. (These are pushed every time when a @case ... of@ scrutinee +-- is evaluated.) +-- +-- @since base-4.17.0.0 +decode :: StackSnapshot -> IO [StackEntry] +decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot + +toStackEntry :: InfoProv -> StackEntry +toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + closureType = ipDesc infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] +getDecodedStackArray (StackSnapshot s) = + IO $ \s0 -> case decodeStack# s s0 of + (# s1, arr #) -> + let n = I# (sizeofByteArray# arr) `div` wordSize - 1 + in unIO (go arr n) s1 + where + go :: ByteArray# -> Int -> IO [Maybe StackEntry] + go _stack (-1) = return [] + go stack i = do + infoProv <- lookupIPE (stackEntryAt stack i) + rest <- unsafeInterleaveIO $ go stack (i-1) + return ((toStackEntry `fmap` infoProv) : rest) + + stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable + stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i) + + wordSize = sizeOf (nullPtr :: Ptr ()) + +prettyStackEntry :: StackEntry -> String +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = + " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -14,17 +14,7 @@ {-# LANGUAGE UnliftedFFITypes #-} module GHC.Internal.Stack.Decode ( - -- * High-level stack decoders - decode, decodeStack, - decodeStackWithIpe, - -- * Stack decoder helpers - decodeStackWithFrameUnpack, - -- * StackEntry - StackEntry(..), - -- * Pretty printing - prettyStackEntry, - prettyStackFrameWithIpe, ) where @@ -34,10 +24,7 @@ import GHC.Internal.Real import GHC.Internal.Word import GHC.Internal.Num import GHC.Internal.Data.Bits -import GHC.Internal.Data.Functor -import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Data.List -import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Exts @@ -58,7 +45,6 @@ import GHC.Internal.Heap.InfoTable import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack -import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -170,17 +156,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# --- | Get the 'StgInfoTable' of the stack frame. --- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable getInfoTableOnStack stackSnapshot# index = - let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) - in - (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#) + let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) + in peekItbl infoTablePtr getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -299,66 +282,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info _ nextChunk -> do - stackClosure <- decodeStack nextChunk - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - ) - (\ frame _ -> pure frame) - -unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] -unpackStackFrameWithIpe stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do - framesWithIpe <- decodeStackWithIpe nextChunk - pure - [ ( UnderflowFrame - { info_tbl = info, - nextChunk = - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = getStackFields stack#, - ssc_stack = map fst framesWithIpe - } - } - , mIpe - ) - ] - ) - (\ frame mIpe -> pure [(frame, mIpe)]) - -unpackStackFrameTo :: - forall a . - StackFrameLocation -> - -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> - -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> - -- ^ How to handle all other 'StackFrame' values. - IO a -unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do + info <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: - StgInfoTable -> - (StackSnapshot -> IO a) -> - (StackFrame -> IO a) -> - IO a - unpackStackFrame' info mkUnderflowResult mkStackFrameResult = + unpackStackFrame' :: StgInfoTable -> IO StackFrame + unpackStackFrame' info = case tipe info of RET_BCO -> do let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) - mkStackFrameResult + pure RetBCO { info_tbl = info, bco = bco', @@ -367,14 +302,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - mkStackFrameResult $ + pure $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - mkStackFrameResult $ + pure $ RetBig { info_tbl = info, stack_payload = payload' @@ -386,7 +321,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - mkStackFrameResult $ + pure $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -396,26 +331,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - mkStackFrameResult $ + pure $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - mkStackFrameResult $ + pure $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - mkUnderflowResult nextChunk' - STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} + stackClosure <- decodeStack nextChunk' + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + STOP_FRAME -> pure $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - mkStackFrameResult $ + pure $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -426,7 +366,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - mkStackFrameResult $ + pure $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -437,7 +377,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - mkStackFrameResult $ + pure $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -446,7 +386,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - mkStackFrameResult $ + pure $ AnnFrame { info_tbl = info, annotation = annotation @@ -464,54 +404,6 @@ intToWord# i = int2Word# (toInt# i) wordOffsetToWord# :: WordOffset -> Word# wordOffsetToWord# wo = intToWord# (fromIntegral wo) --- ---------------------------------------------------------------------------- --- Simplified source location representation of provenance information --- ---------------------------------------------------------------------------- - --- | Representation for the source location where a return frame was pushed on the stack. --- This happens every time when a @case ... of@ scrutinee is evaluated. -data StackEntry = StackEntry - { functionName :: String, - moduleName :: String, - srcLoc :: String, - closureType :: ClosureType - } - deriving (Show, Eq) - -toStackEntry :: InfoProv -> StackEntry -toStackEntry infoProv = - StackEntry - { functionName = ipLabel infoProv, - moduleName = ipMod infoProv, - srcLoc = ipLoc infoProv, - closureType = ipDesc infoProv - } - --- ---------------------------------------------------------------------------- --- Stack decoders --- ---------------------------------------------------------------------------- - --- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). --- The stack trace is created from return frames with according 'InfoProvEnt' --- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are --- no 'InfoProvEnt' entries, an empty list is returned. --- --- Please note: --- --- * To gather 'StackEntry' from libraries, these have to be --- compiled with @-finfo-table-map@, too. --- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change --- with different GHC parameters and versions. --- * The stack trace is empty (by design) if there are no return frames on --- the stack. (These are pushed every time when a @case ... of@ scrutinee --- is evaluated.) --- --- @since base-4.17.0.0 -decode :: StackSnapshot -> IO [StackEntry] -decode stackSnapshot = - (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot - - -- | Location of a stackframe on the stack -- -- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom @@ -524,31 +416,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack snapshot@(StackSnapshot stack#) = do - (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot - pure - GenStgStackClosure - { ssc_info = stackInfo, - ssc_stack_size = getStackFields stack#, - ssc_stack = ssc_stack - } - -decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)] -decodeStackWithIpe snapshot = - concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot - --- ---------------------------------------------------------------------------- --- Write your own stack decoder! --- ---------------------------------------------------------------------------- - -decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) -decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do +decodeStack (StackSnapshot stack#) = do info <- getInfoTableForStack stack# case tipe info of STACK -> do - let sfls = stackFrameLocations stack# - stack' <- mapM unpackFrame sfls - pure (info, stack') + let stack_size' = getStackFields stack# + sfls = stackFrameLocations stack# + stack' <- mapM unpackStackFrame sfls + pure $ + GenStgStackClosure + { ssc_info = info, + ssc_stack_size = stack_size', + ssc_stack = stack' + } _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] @@ -559,21 +439,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do go :: Maybe StackFrameLocation -> [StackFrameLocation] go Nothing = [] go (Just r) = r : go (advanceStackFrameLocation r) - --- ---------------------------------------------------------------------------- --- Pretty printing functions for stack entries, stack frames and provenance info --- ---------------------------------------------------------------------------- - -prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String -prettyStackFrameWithIpe (frame, mipe) = - case frame of - AnnFrame {annotation = Box someStackAnno } -> - case unsafeCoerce someStackAnno of - SomeStackAnnotation ann -> - Just $ displayStackAnnotation ann - _ -> - (prettyStackEntry . toStackEntry) <$> mipe - -prettyStackEntry :: StackEntry -> String -prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = - mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/T26507.stderr ===================================== @@ -0,0 +1,8 @@ +T26507: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +Throw error + +IPE backtrace: +HasCallStack backtrace: + throwIO, called at T26507.hs:7:3 in main:Main + ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,4 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [extra_ways(['prof']), when(js_arch(), skip), exit_code(1)], compile_and_run, ['']) + ===================================== rts/CloneStack.c ===================================== @@ -26,6 +26,11 @@ #include <string.h> +static StgWord getStackFrameCount(StgStack* stack); +static StgWord getStackChunkClosureCount(StgStack* stack); +static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes); +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack); + static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) { StgWord spOffset = stack->sp - stack->stack; @@ -107,3 +112,94 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) + +// Creates a MutableArray# (Haskell representation) that contains a +// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the +// array is the count of stack frames. +// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack +// frame it's represented by null. +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) { + StgWord closureCount = getStackFrameCount(stack); + + StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount); + + copyPtrsToArray(array, stack); + + return array; +} + +// Count the stack frames that are on the given stack. +// This is the sum of all stack frames in all stack chunks of this stack. +StgWord getStackFrameCount(StgStack* stack) { + StgWord closureCount = 0; + StgStack *last_stack = stack; + while (true) { + closureCount += getStackChunkClosureCount(last_stack); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } + return closureCount; +} + +StgWord getStackChunkClosureCount(StgStack* stack) { + StgWord closureCount = 0; + StgPtr sp = stack->sp; + StgPtr spBottom = stack->stack + stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + closureCount++; + } + + return closureCount; +} + +// Allocate and initialize memory for a ByteArray# (Haskell representation). +StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) { + // Idea stolen from PrimOps.cmm:stg_newArrayzh() + StgWord words = sizeofW(StgArrBytes) + bytes; + + StgArrBytes* array = (StgArrBytes*) allocate(cap, words); + + SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM); + array->bytes = bytes; + return array; +} + +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) { + StgWord index = 0; + StgStack *last_stack = stack; + const StgInfoTable **result = (const StgInfoTable **) arr->payload; + while (true) { + StgPtr sp = last_stack->sp; + StgPtr spBottom = last_stack->stack + last_stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; + result[index] = infoTable; + index++; + } + + // Ensure that we didn't overflow the result array + ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*)); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } +} ===================================== rts/CloneStack.h ===================================== @@ -15,6 +15,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); + #include "BeginPrivate.h" #if defined(THREADED_RTS) ===================================== rts/RtsSymbols.c ===================================== @@ -943,6 +943,7 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ + SymI_HasProto(decodeClonedStack) \ SymI_HasProto(stg_newPromptTagzh) \ SymI_HasProto(stg_promptzh) \ SymI_HasProto(stg_control0zh) \ ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -14717,7 +14717,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -16229,8 +16229,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11938,7 +11938,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13469,8 +13469,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40f0ccb0f7d0cbe6d03b1ac66e1073… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40f0ccb0f7d0cbe6d03b1ac66e1073… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/revert-backtrace-decoder] Add regression test for #26507
by Hannes Siebenhandl (＠fendor) 19 Oct '25

19 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC Commits: 40f0ccb0 by fendor at 2025-10-18T20:15:43+02:00 Add regression test for #26507 - - - - - 2 changed files: - + libraries/ghc-internal/tests/backtraces/T26507.hs - libraries/ghc-internal/tests/backtraces/all.T Changes: ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Control.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,4 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [extra_ways(['prof']), when(js_arch(), skip)], compile_and_run, ['']) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f0ccb0f7d0cbe6d03b1ac66e1073d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f0ccb0f7d0cbe6d03b1ac66e1073d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/revert-backtrace-decoder] 30 commits: Improve how we detect user type errors in types
by Hannes Siebenhandl (＠fendor) 19 Oct '25

19 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC Commits: 7471eb6a by sheaf at 2025-10-07T21:39:43-04:00 Improve how we detect user type errors in types This commit cleans up all the code responsible for detecting whether a type contains "TypeError msg" applications nested inside it. All the logic is now in 'userTypeError_maybe', which is always deep. Whether it looks inside type family applications is determined by the passed-in boolean flag: - When deciding whether a constraint is definitely insoluble, don't look inside type family applications, as they may still reduce -- in which case the TypeError could disappear. - When reporting unsolved constraints, look inside type family applications: they had the chance to reduce but didn't, and the custom type error might contain valuable information. All the details are explained in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. Another benefit of this change is that it allows us to get rid of the deeply dodgy 'getUserTypeErrorMsg' function. This commit also improves the detection of custom type errors, for example in equality constraints: TypeError blah ~# rhs It used to be the case that we didn't detect the TypeError on the LHS, because we never considered that equality constraints could be insoluble due to the presence of custom type errors. Addressing this oversight improves detection of redundant pattern match warnings, fixing #26400. - - - - - 29955267 by Rodrigo Mesquita at 2025-10-07T21:40:25-04:00 cleanup: Drop obsolete settings from config.mk.in These values used to be spliced into the bindist's `config.mk` s.t. when `make` was run, the values were read and written into the bindist installation `settings` file. However, we now carry these values to the bindist directly in the default.target toolchain file, and `make` writes almost nothing to `settings` now (see #26227) The entries deleted in this MR were already unused. Fixes #26478 - - - - - f7adfed2 by ARATA Mizuki at 2025-10-08T08:37:24-04:00 T22033 is only relevant if the word size is 64-bit Fixes #25497 - - - - - ff1650c9 by Ben Gamari at 2025-10-08T08:38:07-04:00 rts/posix: Enforce iteration limit on heap reservation logic Previously we could loop indefinitely when attempting to get an address space reservation for our heap. Limit the logic to 8 iterations to ensure we instead issue a reasonable error message. Addresses #26151. - - - - - 01844557 by Ben Gamari at 2025-10-08T08:38:07-04:00 rts/posix: Hold on to low reservations when reserving heap Previously when the OS gave us an address space reservation in low memory we would immediately release it and try again. However, on some platforms this meant that we would get the same allocation again in the next iteration (since mmap's `hint` argument is just that, a hint). Instead we now hold on to low reservations until we have found a suitable heap reservation. Fixes #26151. - - - - - b2c8d052 by Sven Tennie at 2025-10-08T08:38:47-04:00 Build terminfo only in upper stages in cross-builds (#26288) Currently, there's no way to provide library paths for [n]curses for both - build and target - in cross-builds. As stage0 is only used to build upper stages, it should be fine to build terminfo only for them. This re-enables building cross-compilers with terminfo. - - - - - c58f9a61 by Julian Ospald at 2025-10-08T08:39:36-04:00 ghc-toolchain: Drop `ld.gold` from merge object command It's deprecated. Also see #25716 - - - - - 2b8baada by sheaf at 2025-10-08T18:23:37-04:00 Improvements to 'mayLookIdentical' This commit makes significant improvements to the machinery that decides when we should pretty-print the "invisible bits" of a type, such as: - kind applications, e.g. '@k' in 'Proxy @k ty' - RuntimeReps, e.g. 'TYPE r' - multiplicities and linear arrows 'a %1 -> b' To do this, this commit refactors 'mayLookIdentical' to return **which** of the invisible bits don't match up, e.g. in (a %1 -> b) ~ (a %Many -> b) we find that the invisible bit that doesn't match up is a multiplicity, so we should set 'sdocLinearTypes = True' when pretty-printing, and with e.g. Proxy @k1 ~ Proxy @k2 we find that the invisible bit that doesn't match up is an invisible TyCon argument, so we set 'sdocPrintExplicitKinds = True'. We leverage these changes to remove the ad-hoc treatment of linearity of data constructors with 'dataConDisplayType' and 'dataConNonLinearType'. This is now handled by the machinery of 'pprWithInvisibleBits'. Fixes #26335 #26340 - - - - - 129ce32d by sheaf at 2025-10-08T18:23:37-04:00 Store SDoc context in SourceError This commits modifies the SourceError datatype which is used for throwing and then reporting exceptions by storing all the info we need to be able to print the SDoc, including whether we should print with explicit kinds, explicit runtime-reps, etc. This is done using the new datatype: data SourceErrorContext = SEC !DiagOpts !(DiagnosticOpts GhcMessage) Now, when we come to report an error (by handling the exception), we have access to the full context we need. Fixes #26387 - - - - - f9790ca8 by Ben Gamari at 2025-10-08T18:24:19-04:00 gitlab-ci: Make RELEASE_JOB an input Rather than an undocumented variable. - - - - - 14281a22 by Ben Gamari at 2025-10-11T14:06:47-04:00 rts/nonmoving: Fix comment spelling - - - - - bedd38b0 by Ben Gamari at 2025-10-11T14:06:47-04:00 rts/nonmoving: Use atomic operations to update bd->flags - - - - - 215d6841 by Ben Gamari at 2025-10-11T14:06:47-04:00 nonmoving: Use get_itbl instead of explicit loads This is cleaner and also fixes unnecessary (and unsound) use of `volatile`. - - - - - 2c94aa3a by Ben Gamari at 2025-10-11T14:06:47-04:00 rts/Scav: Handle WHITEHOLEs in scavenge_one `scavenge_one`, used to scavenge mutable list entries, may encounter `WHITEHOLE`s when the non-moving GC is in use via two paths: 1. when an MVAR is being marked concurrently 2. when the object belongs to a chain of selectors being short-cutted. Fixes #26204. - - - - - 6bd8155c by Matthew Pickering at 2025-10-11T14:07:29-04:00 Add support for generating bytecode objects This commit adds the `-fwrite-byte-code` option which makes GHC emit a `.gbc` file which contains a serialised representation of bytecode. The bytecode can be loaded by the compiler to avoid having to reinterpret a module when using the bytecode interpreter (for example, in GHCi). There are also the new options: * -gbcdir=<DIR>: Specify the directory to place the gbc files * -gbcsuf=<suffix>: Specify the suffix for gbc files The option `-fbyte-code-and-object-code` now implies `-fwrite-byte-code`. These performance tests fail due to https://github.com/haskell/directory/issues/204 ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiComponentModulesRecomp MultiLayerModulesRecomp MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot T13701 ------------------------- The bytecode serialisation part was implemented by Cheng Shao Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - dc8f9599 by Matthew Pickering at 2025-10-11T14:07:30-04:00 Revert "Add a perf test for #26425" This test has a large memory spike currently, which makes the test sensitive, since if you allocate a little more or less, the precise location where GC happens shifts and you observe a different part of the spike. Andreas told me to revert the patch for now, and he will add it back when he fixes the memory spike. This reverts commit 41bdb16fd083110a06507248f648c507a2feb4af. - - - - - e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00 T22859: Increase threadDelay for small machines The previously used thread delay led to failures on my RISC-V test setups. - - - - - d59ef6b6 by Hai / @BestYeen at 2025-10-14T21:51:14-04:00 Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again. - - - - - c98abb6a by Hai / @BestYeen at 2025-10-14T21:52:08-04:00 Update occurrences of return to pure and add a sample for redefining :m to mean :main - - - - - 70ee825a by Cheng Shao at 2025-10-14T21:52:50-04:00 testsuite: fix T3586 for non-SSE3 platforms `T3586.hs` contains `-fvia-C -optc-msse3` which I think is a best-effort basis to harvest the C compiler's auto vectorization optimizations via the C backend back when the test was added. The `-fvia-C` part is now a deprecated no-op because GHC can't fall back to the C backend on a non-unregisterised build, and `-optc-msse3` might actually cause the test to fail on non x86/x64 platforms, e.g. recent builds of wasi-sdk would report `wasm32-wasi-clang: error: unsupported option '-msse3' for target 'wasm32-unknown-wasi'`. So this patch cleans up this historical cruft. `-fvia-C` is removed, and `-optc-msse3` is only passed when cpuid contains `pni` (which indicates support of SSE3). - - - - - 4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00 Add submodules for template-haskell-lift and template-haskell-quasiquoter These two new boot libraries expose stable subsets of the template-haskell interface. This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696 Work towards #25262 - - - - - 0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00 rts: Eliminate uses of implicit constant arrays Folding of `const`-sized variable-length arrays to a constant-length array is a gnu extension which clang complains about. Closes #26502. - - - - - bf902a1d by Fendor at 2025-10-15T16:00:59-04:00 Refactor distinct constructor tables map construction Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L` `GHC.Data.Word64Map.alterLookup` to support fusion of distinct constructor data insertion and lookup during the construction of the `DataCon` map in `GHC.Stg.Debug.numberDataCon`. Co-authored-by: Fendor <fendor(a)posteo.de> Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com> - - - - - b3585ba1 by Fendor at 2025-10-15T16:00:59-04:00 Allow per constructor refinement of distinct-constructor-tables Introduce `-fno-distinct-constructor-tables`. A distinct constructor table configuration is built from the combination of flags given, in order. For example, to only generate distinct constructor tables for a few specific constructors and no others, just pass `-fdistinct-constructor-tables-only=C1,...,CN`. This flag can be supplied multiple times to extend the set of constructors to generate a distinct info table for. You can disable generation of distinct constructor tables for all configurations by passing `-fno-distinct-constructor-tables`. The various configurations of these flags is included in the `DynFlags` fingerprints, which should result in the expected recompilation logic. Adds a test that checks for distinct tables for various given or omitted constructors. Updates CountDepsAst and CountDepsParser tests to account for new dependencies. Fixes #23703 Co-authored-by: Fendor <fendor(a)posteo.de> Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com> - - - - - e17dc695 by fendor at 2025-10-15T16:01:41-04:00 Fix typos in haddock documentation for stack annotation API - - - - - f85058d3 by Zubin Duggal at 2025-10-17T13:50:52+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 Metric Decrease: T9233 - - - - - c85c845d by sheaf at 2025-10-17T22:35:32-04:00 Don't prematurely final-zonk PatSyn declarations This commit makes GHC hold off on the final zonk for pattern synonym declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. This accommodates the fact that pattern synonym declarations without a type signature can contain unfilled metavariables, e.g. if the RHS of the pattern synonym involves view-patterns whose type mentions promoted (level 0) metavariables. Just like we do for ordinary function bindings, we should allow these metavariables to be settled later, instead of eagerly performing a final zonk-to-type. Now, the final zonking-to-type for pattern synonyms is performed in GHC.Tc.Module.zonkTcGblEnv. Fixes #26465 - - - - - a2334bc7 by Fendor at 2025-10-18T19:21:17+02:00 Revert "Remove stg_decodeStackzh" This reverts commit e0544cc8a9d152c57f35bdd5e940020cc3953489. - - - - - 68bc4d12 by fendor at 2025-10-18T19:21:18+02:00 Revert "Implement `decode` in terms of `decodeStackWithIpe`" This reverts commit bd80bb7013b1c2446557a56779c88e7ad1a06259. - - - - - 243f1aa7 by fendor at 2025-10-18T19:21:18+02:00 Add regression test for #26507 - - - - - 271 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - compiler/GHC.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/ByteCode/Breakpoints.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Data/SmallArray.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/ByteCode.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Config/Finder.hs - compiler/GHC/Driver/Config/Stg/Debug.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Messager.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Flags.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/Debug.hs - + compiler/GHC/Stg/Debug/Types.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Utils/Unify.hs-boot - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/SourceError.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Types/TyThing/Ppr.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DFM.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Supply.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - docs/users_guide/ghci.rst - docs/users_guide/phases.rst - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - hadrian/bindist/config.mk.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - libraries/base/src/GHC/Stack/CloneStack.hs - + libraries/ghc-bignum/gmp/gmp-tarballs - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - libraries/ghc-internal/tests/backtraces/all.T - + libraries/template-haskell-lift - + libraries/template-haskell-quasiquoter - m4/fptools_alex.m4 - m4/fptools_happy.m4 - rts/CloneStack.c - rts/CloneStack.h - rts/Printer.c - rts/RtsSymbols.c - rts/include/rts/storage/Block.h - rts/posix/OSMem.c - rts/sm/NonMoving.c - rts/sm/NonMovingMark.c - rts/sm/Scav.c - testsuite/driver/cpu_features.py - testsuite/tests/bytecode/T24634/T24634a.stdout - testsuite/tests/bytecode/T24634/T24634b.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/cpranal/should_compile/T18174.stderr - testsuite/tests/driver/T11429c.stderr - testsuite/tests/driver/T21682.stderr - + testsuite/tests/driver/bytecode-object/A.hs - + testsuite/tests/driver/bytecode-object/BytecodeForeign.c - + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs - + testsuite/tests/driver/bytecode-object/BytecodeMain.hs - + testsuite/tests/driver/bytecode-object/BytecodeTest.hs - + testsuite/tests/driver/bytecode-object/Makefile - + testsuite/tests/driver/bytecode-object/all.T - + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object19.script - + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object25.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout - testsuite/tests/driver/fat-iface/T22405/T22405.stdout - testsuite/tests/driver/fat-iface/T22405/T22405b.stdout - testsuite/tests/driver/fat-iface/fat011.stderr - testsuite/tests/ghc-api/T10942.hs - + testsuite/tests/ghc-api/T26264.hs - + testsuite/tests/ghc-api/T26264.stdout - testsuite/tests/ghc-api/all.T - testsuite/tests/ghc-api/annotations-literals/literals.hs - testsuite/tests/indexed-types/should_fail/T14887.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/linear/should_fail/T19361.stderr - testsuite/tests/llvm/should_run/all.T - testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr - testsuite/tests/overloadedrecflds/should_fail/T16745.stderr - testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr - + testsuite/tests/patsyn/should_compile/T26465b.hs - + testsuite/tests/patsyn/should_compile/T26465c.hs - + testsuite/tests/patsyn/should_compile/T26465d.hs - + testsuite/tests/patsyn/should_compile/T26465d.stderr - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T26465.hs - + testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/perf/compiler/Makefile - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script - − testsuite/tests/perf/compiler/T26425.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/perf/should_run/T3586.hs - testsuite/tests/perf/should_run/UniqLoop.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/pmcheck/should_compile/T26400.hs - + testsuite/tests/pmcheck/should_compile/T26400.stderr - + testsuite/tests/pmcheck/should_compile/T26400b.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/regalloc/regalloc_unit_tests.hs - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/ipe/distinct-tables/Main.hs - + testsuite/tests/rts/ipe/distinct-tables/Makefile - + testsuite/tests/rts/ipe/distinct-tables/X.hs - + testsuite/tests/rts/ipe/distinct-tables/all.T - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T17673.stderr - testsuite/tests/simplCore/should_compile/T18078.stderr - testsuite/tests/simplCore/should_compile/T18995.stderr - testsuite/tests/simplCore/should_compile/T19890.stderr - testsuite/tests/simplCore/should_compile/T21948.stderr - testsuite/tests/simplCore/should_compile/T21960.stderr - testsuite/tests/simplCore/should_compile/T24808.stderr - − testsuite/tests/simplCore/should_compile/T25713.stderr - testsuite/tests/simplCore/should_compile/T4201.stdout - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/simplStg/should_compile/T22840.stderr - testsuite/tests/th/T8761.stderr - testsuite/tests/typecheck/no_skolem_info/T20232.stderr - testsuite/tests/typecheck/should_fail/T11672.stderr - testsuite/tests/typecheck/should_fail/T12373.stderr - testsuite/tests/typecheck/should_fail/T15807.stderr - testsuite/tests/typecheck/should_fail/T16074.stderr - testsuite/tests/typecheck/should_fail/T18357a.stderr - testsuite/tests/typecheck/should_fail/T19627.stderr - testsuite/tests/typecheck/should_fail/T20241b.stderr - testsuite/tests/typecheck/should_fail/T21530a.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr - testsuite/tests/typecheck/should_fail/VisFlag1.stderr - utils/check-exact/Parsers.hs - utils/check-exact/Preprocess.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97ea4b7c8259acccce731c0bc5625d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97ea4b7c8259acccce731c0bc5625d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/revert-backtrace-decoder] 3 commits: Revert "Remove stg_decodeStackzh"
by Hannes Siebenhandl (＠fendor) 19 Oct '25

19 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC Commits: d486db37 by Fendor at 2025-10-18T18:33:27+02:00 Revert "Remove stg_decodeStackzh" This reverts commit e0544cc8a9d152c57f35bdd5e940020cc3953489. - - - - - 0e33de9b by fendor at 2025-10-18T18:33:27+02:00 Revert "Implement `decode` in terms of `decodeStackWithIpe`" This reverts commit bd80bb7013b1c2446557a56779c88e7ad1a06259. - - - - - 97ea4b7c by fendor at 2025-10-18T18:33:27+02:00 Add regression test for #26507 - - - - - 18 changed files: - libraries/base/src/GHC/Stack/CloneStack.hs - + libraries/ghc-bignum/gmp/gmp-tarballs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - libraries/ghc-internal/tests/backtraces/all.T - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== libraries/base/src/GHC/Stack/CloneStack.hs ===================================== @@ -17,4 +17,3 @@ module GHC.Stack.CloneStack ( ) where import GHC.Internal.Stack.CloneStack -import GHC.Internal.Stack.Decode ===================================== libraries/ghc-bignum/gmp/gmp-tarballs ===================================== @@ -0,0 +1 @@ +Subproject commit 01149ce3471128e9fe0feca607579981f4b64395 ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrszh(P_ stack, W_ offsetWords) { - P_ p, info_struct, info_ptr_ipe_key; +// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrzh(P_ stack, W_ offsetWords) { + P_ p, info; p = StgStack_sp(stack) + WDS(offsetWords); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); - info_struct = %GET_STD_INFO(UNTAG(p)); - info_ptr_ipe_key = %INFO_PTR(UNTAG(p)); - return (info_struct, info_ptr_ipe_key); + info = %GET_STD_INFO(UNTAG(p)); + + return (info); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-internal/cbits/StackCloningDecoding.cmm ===================================== @@ -17,3 +17,10 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { return (); } + +stg_decodeStackzh (gcptr stgStack) { + gcptr stackEntries; + ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); + + return (stackEntries); +} ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) { const StgInfoTable *getItbl(StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); return get_itbl(closure); -} +}; StgWord getBitmapSize(StgClosure *c) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); ===================================== libraries/ghc-internal/jsbits/base.js ===================================== @@ -1245,21 +1245,9 @@ function h$mkdir(path, path_offset, mode) { // It is required by Google Closure Compiler to be at least defined if // somewhere it is used -var h$stg_cloneMyStackzh, - h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh, - h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh, - h$isArgGenBigRetFunTypezh, - h$getUnderflowFrameNextChunkzh, - h$getInfoTableAddrszh, - h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh +var h$stg_cloneMyStackzh, h$stg_decodeStackzh h$stg_cloneMyStackzh - = h$advanceStackFrameLocationzh - = h$getStackFieldszh = h$getStackClosurezh - = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh - = h$isArgGenBigRetFunTypezh - = h$getUnderflowFrameNextChunkzh - = h$getInfoTableAddrszh - = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh + = h$stg_decodeStackzh = function () { throw new Error('Stack Cloning Decoding: Not Implemented Yet') } ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -16,7 +16,6 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack -import qualified GHC.Internal.Stack.Decode as CloneStack import qualified GHC.Internal.Stack.CCS as CCS -- | How to collect a backtrace when an exception is thrown. @@ -144,7 +143,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe + displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs ===================================== @@ -15,20 +15,34 @@ -- @since base-4.17.0.0 module GHC.Internal.Stack.CloneStack ( StackSnapshot(..), + StackEntry(..), cloneMyStack, cloneThreadStack, + decode, + prettyStackEntry ) where import GHC.Internal.MVar +import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Base +import GHC.Internal.Foreign.Storable import GHC.Internal.Conc.Sync +import GHC.Internal.IO (unsafeInterleaveIO) +import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable) +import GHC.Internal.Num +import GHC.Internal.Real (div) import GHC.Internal.Stable +import GHC.Internal.Text.Show +import GHC.Internal.Ptr +import GHC.Internal.ClosureTypes -- | A frozen snapshot of the state of an execution stack. -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #) + foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #) @@ -191,3 +205,64 @@ cloneThreadStack (ThreadId tid#) = do IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #) freeStablePtr boxedPtr takeMVar resultVar + +-- | Representation for the source location where a return frame was pushed on the stack. +-- This happens every time when a @case ... of@ scrutinee is evaluated. +data StackEntry = StackEntry + { functionName :: String, + moduleName :: String, + srcLoc :: String, + closureType :: ClosureType + } + deriving (Show, Eq) + +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). +-- The stack trace is created from return frames with according 'InfoProvEnt' +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are +-- no 'InfoProvEnt' entries, an empty list is returned. +-- +-- Please note: +-- +-- * To gather 'StackEntry' from libraries, these have to be +-- compiled with @-finfo-table-map@, too. +-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change +-- with different GHC parameters and versions. +-- * The stack trace is empty (by design) if there are no return frames on +-- the stack. (These are pushed every time when a @case ... of@ scrutinee +-- is evaluated.) +-- +-- @since base-4.17.0.0 +decode :: StackSnapshot -> IO [StackEntry] +decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot + +toStackEntry :: InfoProv -> StackEntry +toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + closureType = ipDesc infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] +getDecodedStackArray (StackSnapshot s) = + IO $ \s0 -> case decodeStack# s s0 of + (# s1, arr #) -> + let n = I# (sizeofByteArray# arr) `div` wordSize - 1 + in unIO (go arr n) s1 + where + go :: ByteArray# -> Int -> IO [Maybe StackEntry] + go _stack (-1) = return [] + go stack i = do + infoProv <- lookupIPE (stackEntryAt stack i) + rest <- unsafeInterleaveIO $ go stack (i-1) + return ((toStackEntry `fmap` infoProv) : rest) + + stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable + stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i) + + wordSize = sizeOf (nullPtr :: Ptr ()) + +prettyStackEntry :: StackEntry -> String +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = + " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -14,17 +14,7 @@ {-# LANGUAGE UnliftedFFITypes #-} module GHC.Internal.Stack.Decode ( - -- * High-level stack decoders - decode, decodeStack, - decodeStackWithIpe, - -- * Stack decoder helpers - decodeStackWithFrameUnpack, - -- * StackEntry - StackEntry(..), - -- * Pretty printing - prettyStackEntry, - prettyStackFrameWithIpe, ) where @@ -34,10 +24,7 @@ import GHC.Internal.Real import GHC.Internal.Word import GHC.Internal.Num import GHC.Internal.Data.Bits -import GHC.Internal.Data.Functor -import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Data.List -import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Exts @@ -58,7 +45,6 @@ import GHC.Internal.Heap.InfoTable import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack -import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -170,17 +156,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# --- | Get the 'StgInfoTable' of the stack frame. --- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable getInfoTableOnStack stackSnapshot# index = - let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) - in - (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#) + let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) + in peekItbl infoTablePtr getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -299,66 +282,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info _ nextChunk -> do - stackClosure <- decodeStack nextChunk - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - ) - (\ frame _ -> pure frame) - -unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] -unpackStackFrameWithIpe stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do - framesWithIpe <- decodeStackWithIpe nextChunk - pure - [ ( UnderflowFrame - { info_tbl = info, - nextChunk = - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = getStackFields stack#, - ssc_stack = map fst framesWithIpe - } - } - , mIpe - ) - ] - ) - (\ frame mIpe -> pure [(frame, mIpe)]) - -unpackStackFrameTo :: - forall a . - StackFrameLocation -> - -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> - -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> - -- ^ How to handle all other 'StackFrame' values. - IO a -unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do + info <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: - StgInfoTable -> - (StackSnapshot -> IO a) -> - (StackFrame -> IO a) -> - IO a - unpackStackFrame' info mkUnderflowResult mkStackFrameResult = + unpackStackFrame' :: StgInfoTable -> IO StackFrame + unpackStackFrame' info = case tipe info of RET_BCO -> do let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) - mkStackFrameResult + pure RetBCO { info_tbl = info, bco = bco', @@ -367,14 +302,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - mkStackFrameResult $ + pure $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - mkStackFrameResult $ + pure $ RetBig { info_tbl = info, stack_payload = payload' @@ -386,7 +321,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - mkStackFrameResult $ + pure $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -396,26 +331,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - mkStackFrameResult $ + pure $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - mkStackFrameResult $ + pure $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - mkUnderflowResult nextChunk' - STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} + stackClosure <- decodeStack nextChunk' + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + STOP_FRAME -> pure $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - mkStackFrameResult $ + pure $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -426,7 +366,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - mkStackFrameResult $ + pure $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -437,7 +377,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - mkStackFrameResult $ + pure $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -446,7 +386,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - mkStackFrameResult $ + pure $ AnnFrame { info_tbl = info, annotation = annotation @@ -464,54 +404,6 @@ intToWord# i = int2Word# (toInt# i) wordOffsetToWord# :: WordOffset -> Word# wordOffsetToWord# wo = intToWord# (fromIntegral wo) --- ---------------------------------------------------------------------------- --- Simplified source location representation of provenance information --- ---------------------------------------------------------------------------- - --- | Representation for the source location where a return frame was pushed on the stack. --- This happens every time when a @case ... of@ scrutinee is evaluated. -data StackEntry = StackEntry - { functionName :: String, - moduleName :: String, - srcLoc :: String, - closureType :: ClosureType - } - deriving (Show, Eq) - -toStackEntry :: InfoProv -> StackEntry -toStackEntry infoProv = - StackEntry - { functionName = ipLabel infoProv, - moduleName = ipMod infoProv, - srcLoc = ipLoc infoProv, - closureType = ipDesc infoProv - } - --- ---------------------------------------------------------------------------- --- Stack decoders --- ---------------------------------------------------------------------------- - --- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). --- The stack trace is created from return frames with according 'InfoProvEnt' --- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are --- no 'InfoProvEnt' entries, an empty list is returned. --- --- Please note: --- --- * To gather 'StackEntry' from libraries, these have to be --- compiled with @-finfo-table-map@, too. --- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change --- with different GHC parameters and versions. --- * The stack trace is empty (by design) if there are no return frames on --- the stack. (These are pushed every time when a @case ... of@ scrutinee --- is evaluated.) --- --- @since base-4.17.0.0 -decode :: StackSnapshot -> IO [StackEntry] -decode stackSnapshot = - (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot - - -- | Location of a stackframe on the stack -- -- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom @@ -524,31 +416,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack snapshot@(StackSnapshot stack#) = do - (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot - pure - GenStgStackClosure - { ssc_info = stackInfo, - ssc_stack_size = getStackFields stack#, - ssc_stack = ssc_stack - } - -decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)] -decodeStackWithIpe snapshot = - concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot - --- ---------------------------------------------------------------------------- --- Write your own stack decoder! --- ---------------------------------------------------------------------------- - -decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) -decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do +decodeStack (StackSnapshot stack#) = do info <- getInfoTableForStack stack# case tipe info of STACK -> do - let sfls = stackFrameLocations stack# - stack' <- mapM unpackFrame sfls - pure (info, stack') + let stack_size' = getStackFields stack# + sfls = stackFrameLocations stack# + stack' <- mapM unpackStackFrame sfls + pure $ + GenStgStackClosure + { ssc_info = info, + ssc_stack_size = stack_size', + ssc_stack = stack' + } _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] @@ -559,21 +439,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do go :: Maybe StackFrameLocation -> [StackFrameLocation] go Nothing = [] go (Just r) = r : go (advanceStackFrameLocation r) - --- ---------------------------------------------------------------------------- --- Pretty printing functions for stack entries, stack frames and provenance info --- ---------------------------------------------------------------------------- - -prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String -prettyStackFrameWithIpe (frame, mipe) = - case frame of - AnnFrame {annotation = Box someStackAnno } -> - case unsafeCoerce someStackAnno of - SomeStackAnnotation ann -> - Just $ displayStackAnnotation ann - _ -> - (prettyStackEntry . toStackEntry) <$> mipe - -prettyStackEntry :: StackEntry -> String -prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = - mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Control.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,4 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [extra_ways(['prof'])], compile_and_run, ['']) + ===================================== rts/CloneStack.c ===================================== @@ -26,6 +26,11 @@ #include <string.h> +static StgWord getStackFrameCount(StgStack* stack); +static StgWord getStackChunkClosureCount(StgStack* stack); +static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes); +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack); + static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) { StgWord spOffset = stack->sp - stack->stack; @@ -107,3 +112,94 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) + +// Creates a MutableArray# (Haskell representation) that contains a +// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the +// array is the count of stack frames. +// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack +// frame it's represented by null. +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) { + StgWord closureCount = getStackFrameCount(stack); + + StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount); + + copyPtrsToArray(array, stack); + + return array; +} + +// Count the stack frames that are on the given stack. +// This is the sum of all stack frames in all stack chunks of this stack. +StgWord getStackFrameCount(StgStack* stack) { + StgWord closureCount = 0; + StgStack *last_stack = stack; + while (true) { + closureCount += getStackChunkClosureCount(last_stack); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } + return closureCount; +} + +StgWord getStackChunkClosureCount(StgStack* stack) { + StgWord closureCount = 0; + StgPtr sp = stack->sp; + StgPtr spBottom = stack->stack + stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + closureCount++; + } + + return closureCount; +} + +// Allocate and initialize memory for a ByteArray# (Haskell representation). +StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) { + // Idea stolen from PrimOps.cmm:stg_newArrayzh() + StgWord words = sizeofW(StgArrBytes) + bytes; + + StgArrBytes* array = (StgArrBytes*) allocate(cap, words); + + SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM); + array->bytes = bytes; + return array; +} + +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) { + StgWord index = 0; + StgStack *last_stack = stack; + const StgInfoTable **result = (const StgInfoTable **) arr->payload; + while (true) { + StgPtr sp = last_stack->sp; + StgPtr spBottom = last_stack->stack + last_stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; + result[index] = infoTable; + index++; + } + + // Ensure that we didn't overflow the result array + ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*)); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } +} ===================================== rts/CloneStack.h ===================================== @@ -15,6 +15,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); + #include "BeginPrivate.h" #if defined(THREADED_RTS) ===================================== rts/RtsSymbols.c ===================================== @@ -943,6 +943,7 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ + SymI_HasProto(decodeClonedStack) \ SymI_HasProto(stg_newPromptTagzh) \ SymI_HasProto(stg_promptzh) \ SymI_HasProto(stg_control0zh) \ ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -14717,7 +14717,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -16229,8 +16229,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11938,7 +11938,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13469,8 +13469,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe9826bbc3f9179607c840c697c52a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe9826bbc3f9179607c840c697c52a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/revert-backtrace-decoder] 3 commits: Revert "Remove stg_decodeStackzh"
by Hannes Siebenhandl (＠fendor) 19 Oct '25

19 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC Commits: 7f3aa09d by Fendor at 2025-10-18T18:31:34+02:00 Revert "Remove stg_decodeStackzh" This reverts commit e0544cc8a9d152c57f35bdd5e940020cc3953489. - - - - - edaecdfa by fendor at 2025-10-18T18:31:34+02:00 Revert "Implement `decode` in terms of `decodeStackWithIpe`" This reverts commit bd80bb7013b1c2446557a56779c88e7ad1a06259. - - - - - fe9826bb by fendor at 2025-10-18T18:31:34+02:00 Add regression test for #26507 - - - - - 19 changed files: - compiler/GHC/Rename/Unbound.hs - libraries/base/src/GHC/Stack/CloneStack.hs - + libraries/ghc-bignum/gmp/gmp-tarballs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - libraries/ghc-internal/tests/backtraces/all.T - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Rename.Unbound , IsTermInTypes(..) , notInScopeErr , relevantNameSpace - , suggestionIsRelevant + , suggestionIsRelevantp , termNameInType ) where ===================================== libraries/base/src/GHC/Stack/CloneStack.hs ===================================== @@ -17,4 +17,3 @@ module GHC.Stack.CloneStack ( ) where import GHC.Internal.Stack.CloneStack -import GHC.Internal.Stack.Decode ===================================== libraries/ghc-bignum/gmp/gmp-tarballs ===================================== @@ -0,0 +1 @@ +Subproject commit 01149ce3471128e9fe0feca607579981f4b64395 ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrszh(P_ stack, W_ offsetWords) { - P_ p, info_struct, info_ptr_ipe_key; +// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrzh(P_ stack, W_ offsetWords) { + P_ p, info; p = StgStack_sp(stack) + WDS(offsetWords); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); - info_struct = %GET_STD_INFO(UNTAG(p)); - info_ptr_ipe_key = %INFO_PTR(UNTAG(p)); - return (info_struct, info_ptr_ipe_key); + info = %GET_STD_INFO(UNTAG(p)); + + return (info); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-internal/cbits/StackCloningDecoding.cmm ===================================== @@ -17,3 +17,10 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { return (); } + +stg_decodeStackzh (gcptr stgStack) { + gcptr stackEntries; + ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); + + return (stackEntries); +} ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) { const StgInfoTable *getItbl(StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); return get_itbl(closure); -} +}; StgWord getBitmapSize(StgClosure *c) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); ===================================== libraries/ghc-internal/jsbits/base.js ===================================== @@ -1245,21 +1245,9 @@ function h$mkdir(path, path_offset, mode) { // It is required by Google Closure Compiler to be at least defined if // somewhere it is used -var h$stg_cloneMyStackzh, - h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh, - h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh, - h$isArgGenBigRetFunTypezh, - h$getUnderflowFrameNextChunkzh, - h$getInfoTableAddrszh, - h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh +var h$stg_cloneMyStackzh, h$stg_decodeStackzh h$stg_cloneMyStackzh - = h$advanceStackFrameLocationzh - = h$getStackFieldszh = h$getStackClosurezh - = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh - = h$isArgGenBigRetFunTypezh - = h$getUnderflowFrameNextChunkzh - = h$getInfoTableAddrszh - = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh + = h$stg_decodeStackzh = function () { throw new Error('Stack Cloning Decoding: Not Implemented Yet') } ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -16,7 +16,6 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack -import qualified GHC.Internal.Stack.Decode as CloneStack import qualified GHC.Internal.Stack.CCS as CCS -- | How to collect a backtrace when an exception is thrown. @@ -144,7 +143,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe + displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs ===================================== @@ -15,20 +15,34 @@ -- @since base-4.17.0.0 module GHC.Internal.Stack.CloneStack ( StackSnapshot(..), + StackEntry(..), cloneMyStack, cloneThreadStack, + decode, + prettyStackEntry ) where import GHC.Internal.MVar +import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Base +import GHC.Internal.Foreign.Storable import GHC.Internal.Conc.Sync +import GHC.Internal.IO (unsafeInterleaveIO) +import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable) +import GHC.Internal.Num +import GHC.Internal.Real (div) import GHC.Internal.Stable +import GHC.Internal.Text.Show +import GHC.Internal.Ptr +import GHC.Internal.ClosureTypes -- | A frozen snapshot of the state of an execution stack. -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #) + foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #) @@ -191,3 +205,64 @@ cloneThreadStack (ThreadId tid#) = do IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #) freeStablePtr boxedPtr takeMVar resultVar + +-- | Representation for the source location where a return frame was pushed on the stack. +-- This happens every time when a @case ... of@ scrutinee is evaluated. +data StackEntry = StackEntry + { functionName :: String, + moduleName :: String, + srcLoc :: String, + closureType :: ClosureType + } + deriving (Show, Eq) + +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). +-- The stack trace is created from return frames with according 'InfoProvEnt' +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are +-- no 'InfoProvEnt' entries, an empty list is returned. +-- +-- Please note: +-- +-- * To gather 'StackEntry' from libraries, these have to be +-- compiled with @-finfo-table-map@, too. +-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change +-- with different GHC parameters and versions. +-- * The stack trace is empty (by design) if there are no return frames on +-- the stack. (These are pushed every time when a @case ... of@ scrutinee +-- is evaluated.) +-- +-- @since base-4.17.0.0 +decode :: StackSnapshot -> IO [StackEntry] +decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot + +toStackEntry :: InfoProv -> StackEntry +toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + closureType = ipDesc infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] +getDecodedStackArray (StackSnapshot s) = + IO $ \s0 -> case decodeStack# s s0 of + (# s1, arr #) -> + let n = I# (sizeofByteArray# arr) `div` wordSize - 1 + in unIO (go arr n) s1 + where + go :: ByteArray# -> Int -> IO [Maybe StackEntry] + go _stack (-1) = return [] + go stack i = do + infoProv <- lookupIPE (stackEntryAt stack i) + rest <- unsafeInterleaveIO $ go stack (i-1) + return ((toStackEntry `fmap` infoProv) : rest) + + stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable + stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i) + + wordSize = sizeOf (nullPtr :: Ptr ()) + +prettyStackEntry :: StackEntry -> String +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = + " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -14,17 +14,7 @@ {-# LANGUAGE UnliftedFFITypes #-} module GHC.Internal.Stack.Decode ( - -- * High-level stack decoders - decode, decodeStack, - decodeStackWithIpe, - -- * Stack decoder helpers - decodeStackWithFrameUnpack, - -- * StackEntry - StackEntry(..), - -- * Pretty printing - prettyStackEntry, - prettyStackFrameWithIpe, ) where @@ -34,10 +24,7 @@ import GHC.Internal.Real import GHC.Internal.Word import GHC.Internal.Num import GHC.Internal.Data.Bits -import GHC.Internal.Data.Functor -import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Data.List -import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Exts @@ -58,7 +45,6 @@ import GHC.Internal.Heap.InfoTable import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack -import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -170,17 +156,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# --- | Get the 'StgInfoTable' of the stack frame. --- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable getInfoTableOnStack stackSnapshot# index = - let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) - in - (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#) + let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) + in peekItbl infoTablePtr getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -299,66 +282,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info _ nextChunk -> do - stackClosure <- decodeStack nextChunk - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - ) - (\ frame _ -> pure frame) - -unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] -unpackStackFrameWithIpe stackFrameLoc = do - unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do - framesWithIpe <- decodeStackWithIpe nextChunk - pure - [ ( UnderflowFrame - { info_tbl = info, - nextChunk = - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = getStackFields stack#, - ssc_stack = map fst framesWithIpe - } - } - , mIpe - ) - ] - ) - (\ frame mIpe -> pure [(frame, mIpe)]) - -unpackStackFrameTo :: - forall a . - StackFrameLocation -> - -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> - -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> - -- ^ How to handle all other 'StackFrame' values. - IO a -unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do + info <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: - StgInfoTable -> - (StackSnapshot -> IO a) -> - (StackFrame -> IO a) -> - IO a - unpackStackFrame' info mkUnderflowResult mkStackFrameResult = + unpackStackFrame' :: StgInfoTable -> IO StackFrame + unpackStackFrame' info = case tipe info of RET_BCO -> do let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) - mkStackFrameResult + pure RetBCO { info_tbl = info, bco = bco', @@ -367,14 +302,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - mkStackFrameResult $ + pure $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - mkStackFrameResult $ + pure $ RetBig { info_tbl = info, stack_payload = payload' @@ -386,7 +321,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - mkStackFrameResult $ + pure $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -396,26 +331,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - mkStackFrameResult $ + pure $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - mkStackFrameResult $ + pure $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - mkUnderflowResult nextChunk' - STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} + stackClosure <- decodeStack nextChunk' + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + STOP_FRAME -> pure $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - mkStackFrameResult $ + pure $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -426,7 +366,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - mkStackFrameResult $ + pure $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -437,7 +377,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - mkStackFrameResult $ + pure $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -446,7 +386,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - mkStackFrameResult $ + pure $ AnnFrame { info_tbl = info, annotation = annotation @@ -464,54 +404,6 @@ intToWord# i = int2Word# (toInt# i) wordOffsetToWord# :: WordOffset -> Word# wordOffsetToWord# wo = intToWord# (fromIntegral wo) --- ---------------------------------------------------------------------------- --- Simplified source location representation of provenance information --- ---------------------------------------------------------------------------- - --- | Representation for the source location where a return frame was pushed on the stack. --- This happens every time when a @case ... of@ scrutinee is evaluated. -data StackEntry = StackEntry - { functionName :: String, - moduleName :: String, - srcLoc :: String, - closureType :: ClosureType - } - deriving (Show, Eq) - -toStackEntry :: InfoProv -> StackEntry -toStackEntry infoProv = - StackEntry - { functionName = ipLabel infoProv, - moduleName = ipMod infoProv, - srcLoc = ipLoc infoProv, - closureType = ipDesc infoProv - } - --- ---------------------------------------------------------------------------- --- Stack decoders --- ---------------------------------------------------------------------------- - --- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). --- The stack trace is created from return frames with according 'InfoProvEnt' --- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are --- no 'InfoProvEnt' entries, an empty list is returned. --- --- Please note: --- --- * To gather 'StackEntry' from libraries, these have to be --- compiled with @-finfo-table-map@, too. --- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change --- with different GHC parameters and versions. --- * The stack trace is empty (by design) if there are no return frames on --- the stack. (These are pushed every time when a @case ... of@ scrutinee --- is evaluated.) --- --- @since base-4.17.0.0 -decode :: StackSnapshot -> IO [StackEntry] -decode stackSnapshot = - (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot - - -- | Location of a stackframe on the stack -- -- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom @@ -524,31 +416,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack snapshot@(StackSnapshot stack#) = do - (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot - pure - GenStgStackClosure - { ssc_info = stackInfo, - ssc_stack_size = getStackFields stack#, - ssc_stack = ssc_stack - } - -decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)] -decodeStackWithIpe snapshot = - concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot - --- ---------------------------------------------------------------------------- --- Write your own stack decoder! --- ---------------------------------------------------------------------------- - -decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) -decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do +decodeStack (StackSnapshot stack#) = do info <- getInfoTableForStack stack# case tipe info of STACK -> do - let sfls = stackFrameLocations stack# - stack' <- mapM unpackFrame sfls - pure (info, stack') + let stack_size' = getStackFields stack# + sfls = stackFrameLocations stack# + stack' <- mapM unpackStackFrame sfls + pure $ + GenStgStackClosure + { ssc_info = info, + ssc_stack_size = stack_size', + ssc_stack = stack' + } _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] @@ -559,21 +439,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do go :: Maybe StackFrameLocation -> [StackFrameLocation] go Nothing = [] go (Just r) = r : go (advanceStackFrameLocation r) - --- ---------------------------------------------------------------------------- --- Pretty printing functions for stack entries, stack frames and provenance info --- ---------------------------------------------------------------------------- - -prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String -prettyStackFrameWithIpe (frame, mipe) = - case frame of - AnnFrame {annotation = Box someStackAnno } -> - case unsafeCoerce someStackAnno of - SomeStackAnnotation ann -> - Just $ displayStackAnnotation ann - _ -> - (prettyStackEntry . toStackEntry) <$> mipe - -prettyStackEntry :: StackEntry -> String -prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = - mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Control.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,4 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [extra_ways(['prof'])], compile_and_run, ['']) + ===================================== rts/CloneStack.c ===================================== @@ -26,6 +26,11 @@ #include <string.h> +static StgWord getStackFrameCount(StgStack* stack); +static StgWord getStackChunkClosureCount(StgStack* stack); +static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes); +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack); + static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) { StgWord spOffset = stack->sp - stack->stack; @@ -107,3 +112,94 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) + +// Creates a MutableArray# (Haskell representation) that contains a +// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the +// array is the count of stack frames. +// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack +// frame it's represented by null. +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) { + StgWord closureCount = getStackFrameCount(stack); + + StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount); + + copyPtrsToArray(array, stack); + + return array; +} + +// Count the stack frames that are on the given stack. +// This is the sum of all stack frames in all stack chunks of this stack. +StgWord getStackFrameCount(StgStack* stack) { + StgWord closureCount = 0; + StgStack *last_stack = stack; + while (true) { + closureCount += getStackChunkClosureCount(last_stack); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } + return closureCount; +} + +StgWord getStackChunkClosureCount(StgStack* stack) { + StgWord closureCount = 0; + StgPtr sp = stack->sp; + StgPtr spBottom = stack->stack + stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + closureCount++; + } + + return closureCount; +} + +// Allocate and initialize memory for a ByteArray# (Haskell representation). +StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) { + // Idea stolen from PrimOps.cmm:stg_newArrayzh() + StgWord words = sizeofW(StgArrBytes) + bytes; + + StgArrBytes* array = (StgArrBytes*) allocate(cap, words); + + SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM); + array->bytes = bytes; + return array; +} + +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) { + StgWord index = 0; + StgStack *last_stack = stack; + const StgInfoTable **result = (const StgInfoTable **) arr->payload; + while (true) { + StgPtr sp = last_stack->sp; + StgPtr spBottom = last_stack->stack + last_stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; + result[index] = infoTable; + index++; + } + + // Ensure that we didn't overflow the result array + ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*)); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } +} ===================================== rts/CloneStack.h ===================================== @@ -15,6 +15,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); + #include "BeginPrivate.h" #if defined(THREADED_RTS) ===================================== rts/RtsSymbols.c ===================================== @@ -943,6 +943,7 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ + SymI_HasProto(decodeClonedStack) \ SymI_HasProto(stg_newPromptTagzh) \ SymI_HasProto(stg_promptzh) \ SymI_HasProto(stg_control0zh) \ ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -14717,7 +14717,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -16229,8 +16229,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11938,7 +11938,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13469,8 +13469,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b92e2bf60bfacbf2c38cb364e0532d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b92e2bf60bfacbf2c38cb364e0532d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/revert-backtrace-decoder
by Hannes Siebenhandl (＠fendor) 18 Oct '25

18 Oct '25

Hannes Siebenhandl pushed new branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/revert-backtrace-decod… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Don't prematurely final-zonk PatSyn declarations
by Marge Bot (＠marge-bot) 18 Oct '25

18 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c85c845d by sheaf at 2025-10-17T22:35:32-04:00 Don't prematurely final-zonk PatSyn declarations This commit makes GHC hold off on the final zonk for pattern synonym declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. This accommodates the fact that pattern synonym declarations without a type signature can contain unfilled metavariables, e.g. if the RHS of the pattern synonym involves view-patterns whose type mentions promoted (level 0) metavariables. Just like we do for ordinary function bindings, we should allow these metavariables to be settled later, instead of eagerly performing a final zonk-to-type. Now, the final zonking-to-type for pattern synonyms is performed in GHC.Tc.Module.zonkTcGblEnv. Fixes #26465 - - - - - 6daf7dbd by Rodrigo Mesquita at 2025-10-18T06:46:40-04:00 Move code-gen aux symbols from ghc-internal to rts These symbols were all previously defined in ghc-internal and made the dependency structure awkward, where the rts may refer to some of these symbols and had to work around that circular dependency the way described in #26166. Moreover, the code generator will produce code that uses these symbols! Therefore, they should be available in the rts: PRINCIPLE: If the code generator may produce code which uses this symbol, then it should be defined in the rts rather than, say, ghc-internal. That said, the main motivation is towards fixing #26166. Towards #26166. Pre-requisite of !14892 - - - - - 1a77881c by Ben Gamari at 2025-10-18T06:46:40-04:00 rts: Avoid static symbol references to ghc-internal This resolves #26166, a bug due to new constraints placed by Apple's linker on undefined references. One source of such references in the RTS is the many symbols referenced in ghc-internal. To mitigate #26166, we make these references dynamic, as described in Note [RTS/ghc-internal interface]. Fixes #26166 Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 600b2f57 by Ben Gamari at 2025-10-18T06:46:40-04:00 compiler: Rename isMathFun -> isLibcFun This set includes more than just math functions. - - - - - 1af0caf6 by Ben Gamari at 2025-10-18T06:46:40-04:00 compiler: Add libc allocator functions to libc_funs Prototypes for these are now visible from `Prim.h`, resulting in multiple-declaration warnings in the unregisterised job. - - - - - 25e00507 by Ben Gamari at 2025-10-18T06:46:40-04:00 rts: Minimize header dependencies of Prim.h Otherwise we will end up with redundant and incompatible declarations resulting in warnings during the unregisterised build. - - - - - 87846a20 by Diego Antonio Rosario Palomino at 2025-10-18T06:46:46-04:00 Cmm Parser: Fix incorrect example in comment The Parser.y file contains a comment with an incorrect example of textual Cmm (used in .cmm files). This commit updates the comment to ensure it reflects valid textual Cmm syntax. Fixes #26313 - - - - - 69 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToC.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/Language/Haskell/Syntax/Binds.hs - hadrian/src/Settings/Packages.hs - + libraries/ghc-internal/cbits/RtsIface.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/include/RtsIfaceSymbols.h - rts/BuiltinClosures.c - rts/CloneStack.h - rts/Compact.cmm - rts/ContinuationOps.cmm - rts/Exception.cmm - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsAPI.c - rts/RtsStartup.c - rts/RtsSymbols.c - + rts/RtsToHsIface.c - rts/StgStdThunks.cmm - rts/configure.ac - − rts/external-symbols.list.in - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - + rts/include/rts/RtsToHsIface.h - rts/include/rts/Types.h - rts/include/stg/Prim.h - rts/posix/Signals.c - libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c - libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c - libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c - libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c - libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c - libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c - libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c - libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c - libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c - libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c - libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c - libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c - libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c - − rts/rts.buildinfo.in - rts/rts.cabal - rts/wasm/JSFFI.c - rts/wasm/scheduler.cmm - rts/win32/libHSghc-internal.def - + testsuite/tests/patsyn/should_compile/T26465b.hs - + testsuite/tests/patsyn/should_compile/T26465c.hs - + testsuite/tests/patsyn/should_compile/T26465d.hs - + testsuite/tests/patsyn/should_compile/T26465d.stderr - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T26465.hs - + testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/th/T8761.stderr - utils/deriveConstants/Main.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8bc5f2e923871e97f9fe63751b3da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8bc5f2e923871e97f9fe63751b3da… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Don't prematurely final-zonk PatSyn declarations
by Marge Bot (＠marge-bot) 18 Oct '25

18 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c85c845d by sheaf at 2025-10-17T22:35:32-04:00 Don't prematurely final-zonk PatSyn declarations This commit makes GHC hold off on the final zonk for pattern synonym declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. This accommodates the fact that pattern synonym declarations without a type signature can contain unfilled metavariables, e.g. if the RHS of the pattern synonym involves view-patterns whose type mentions promoted (level 0) metavariables. Just like we do for ordinary function bindings, we should allow these metavariables to be settled later, instead of eagerly performing a final zonk-to-type. Now, the final zonking-to-type for pattern synonyms is performed in GHC.Tc.Module.zonkTcGblEnv. Fixes #26465 - - - - - 16 changed files: - compiler/GHC/Core/Make.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/Language/Haskell/Syntax/Binds.hs - + testsuite/tests/patsyn/should_compile/T26465b.hs - + testsuite/tests/patsyn/should_compile/T26465c.hs - + testsuite/tests/patsyn/should_compile/T26465d.hs - + testsuite/tests/patsyn/should_compile/T26465d.stderr - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T26465.hs - + testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/th/T8761.stderr Changes: ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -111,7 +111,7 @@ sortQuantVars vs = sorted_tcvs ++ ids -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "GHC.Core#let_can_float_invariant") -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet :: HasDebugCallStack => CoreBind -> CoreExpr -> CoreExpr mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant] = bindNonRec bndr rhs body mkCoreLet bind body @@ -133,7 +133,7 @@ mkCoreTyLams binders body = mkCast lam co -- | Bind a list of binding groups over an expression. The leftmost binding -- group becomes the outermost group in the resulting expression -mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets :: HasDebugCallStack => [CoreBind] -> CoreExpr -> CoreExpr mkCoreLets binds body = foldr mkCoreLet body binds -- | Construct an expression which represents the application of a number of ===================================== compiler/GHC/Core/PatSyn.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Core.PatSyn ( -- * Main data types - PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, + PatSyn(..), PatSynMatcher, PatSynBuilder, mkPatSyn, -- ** Type deconstruction patSynName, patSynArity, patSynVisArity, ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -259,12 +259,12 @@ wrapBind new old body -- NB: this function must deal with term seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = mkDefaultCase (Var var) var body -mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr +mkCoLetMatchResult :: HasDebugCallStack => CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr mkCoLetMatchResult bind = fmap (mkCoreLet bind) -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkViewMatchResult :: HasDebugCallStack => Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -579,7 +579,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - ; (id_env, ev_binds', binds', fords', imp_specs', rules') + ; (id_env, ev_binds', binds', fords', imp_specs', rules', pat_syns') <- zonkTcGblEnv new_ev_binds tcg_env --------- Run finalizers -------------- @@ -597,6 +597,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls , tcg_imp_specs = [] , tcg_rules = [] , tcg_fords = [] + , tcg_patsyns = [] , tcg_type_env = tcg_type_env tcg_env `plusTypeEnv` id_env } ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env @@ -628,7 +629,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Zonk the new bindings arising from running the finalisers, -- and main. This won't give rise to any more finalisers as you -- can't nest finalisers inside finalisers. - ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf, patsyns_mf) <- zonkTcGblEnv main_ev_binds tcg_env ; let { !final_type_env = tcg_type_env tcg_env @@ -642,24 +643,26 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf , tcg_imp_specs = imp_specs' ++ imp_specs_mf , tcg_rules = rules' ++ rules_mf - , tcg_fords = fords' ++ fords_mf } } ; + , tcg_fords = fords' ++ fords_mf + , tcg_patsyns = pat_syns' ++ patsyns_mf } } ; ; setGlobalTypeEnv tcg_env' final_type_env } zonkTcGblEnv :: Bag EvBind -> TcGblEnv -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc], [PatSyn]) zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds , tcg_ev_binds = cur_ev_binds , tcg_imp_specs = imp_specs , tcg_rules = rules - , tcg_fords = fords }) + , tcg_fords = fords + , tcg_patsyns = pat_syns }) = {-# SCC "zonkTopDecls" #-} setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering -- error messages during zonking (notably levity errors) do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds - ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + ; zonkTopDecls all_ev_binds binds rules imp_specs fords pat_syns } -- | Runs TH finalizers and renames and typechecks the top-level declarations -- that they could introduce. ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Zonk.Type import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Zonk.TcType @@ -37,10 +36,10 @@ import GHC.Tc.Types.Origin import GHC.Tc.TyCl.Build import GHC.Core.Multiplicity -import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp ) +import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp, definitelyLiftedType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) -import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType ) import GHC.Core.Predicate +import GHC.Core.TyCo.Tidy import GHC.Types.Name import GHC.Types.Name.Reader @@ -51,7 +50,7 @@ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Var -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList ) +import GHC.Types.Var.Env( mkInScopeSetList, emptyTidyEnv ) import GHC.Types.Id import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind @@ -672,27 +671,31 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- - initZonkEnv NoFlexi $ - runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> - do { req_theta' <- zonkTcTypesToTypesX req_theta - ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> - do { prov_theta' <- zonkTcTypesToTypesX prov_theta - ; pat_ty' <- zonkTcTypeToTypeX pat_ty - ; arg_tys' <- zonkTcTypesToTypesX arg_tys + = do { -- Don't do a final zonk-to-type yet, as the pattern synonym may still + -- contain unfilled metavariables. + -- See Note [Metavariables in pattern synonyms]. + + -- We still need to zonk, however, in order for instantiation to work + -- correctly. If we don't zonk, we are at risk of quantifying + -- 'alpha -> beta' to 'forall a. a -> beta' even though 'beta := alpha'. + ; (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- + liftZonkM $ + do { univ_tvs' <- traverse zonkInvisTVBinder univ_tvs + ; req_theta' <- zonkTcTypes req_theta + ; ex_tvs' <- traverse zonkInvisTVBinder ex_tvs + ; prov_theta' <- zonkTcTypes prov_theta + ; pat_ty' <- zonkTcType pat_ty + ; arg_tys' <- zonkTcTypes arg_tys ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + req_theta = tidyTypes env1 req_theta' (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' prov_theta = tidyTypes env2 prov_theta' arg_tys = tidyTypes env2 arg_tys' pat_ty = tidyType env2 pat_ty' ; return (univ_tvs, req_theta, - ex_tvs, prov_theta, arg_tys, pat_ty) } } + ex_tvs, prov_theta, arg_tys, pat_ty) } ; traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ @@ -734,6 +737,48 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ; traceTc "tc_patsyn_finish }" empty ; return (matcher_bind, tcg_env) } +{- Note [Metavariables in pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike data constructors, the types of pattern synonyms are allowed to contain +metavariables, because of view patterns. Example (from ticket #26465): + + f :: Eq a => a -> Maybe a + f = ... + + g = f + -- Due to the monomorphism restriction, we infer + -- g :: alpha -> Maybe alpha, with [W] Eq alpha + + pattern P x <- (g -> Just x) + -- Infer: P :: alpha -> alpha + +Note that: + + 1. 'g' is a top-level function binding whose inferred type contains metavariables + (due to type variable promotion, as described in Note [Deciding quantification] in GHC.Tc.Solver) + 2. 'P' is a pattern synonym without a type signature which uses 'g' in a view pattern. + +In this way, promoted metavariables of top-level functions can sneak their way +into pattern synonym definitions. + +To account for this fact, we do not attempt a final zonk-to-type in +'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. Indeed, GHC may fill in the metavariables +when typechecking the rest of the module. Following on from the above example, +we might have a later binding: + + y = g 'c' + -- fixes alpha := Char + +or + + h (P b) = not b + -- fixes alpha := Bool + +We instead perform the final zonk-to-type at the very end, in the call +to 'GHC.Tc.Zonk.Type.zonkPatSyn' in 'GHC.Tc.Zonk.Type.zonkTopDecls'. In this way, +pattern synonyms are treated the same as top-level function bindings. +-} + {- ************************************************************************ * * @@ -870,9 +915,11 @@ mkPatSynBuilder dir (L _ name) | otherwise = do { builder_name <- newImplicitBinder name mkBuilderOcc ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - -- NB: pattern arguments cannot be representation-polymorphic, - -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here. + need_dummy_arg = null arg_tys && null theta && not (definitelyLiftedType pat_ty) + -- At this point, the representation of 'pat_ty' might still be unknown (see T26465c), + -- so use a conservative test that handles an unknown representation. + -- Ideally, we'd defer making the builder until the representation is settled, + -- but that would be a lot more work. builder_sigma = add_void need_dummy_arg $ mkInvisForAllTys univ_bndrs $ mkInvisForAllTys ex_bndrs $ ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -37,9 +37,6 @@ module GHC.Tc.Zonk.Type ( import GHC.Prelude import GHC.Builtin.Types - -import GHC.Core.TyCo.Ppr ( pprTyVar ) - import GHC.Hs import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) @@ -60,8 +57,11 @@ import GHC.Tc.Zonk.TcType , checkCoercionHole , zonkCoVar ) -import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.PatSyn (PatSyn(..)) +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Core.Type import GHC.Core.TyCon import GHC.Utils.Outputable @@ -93,6 +93,7 @@ import Control.Monad import Control.Monad.Trans.Class ( lift ) import Data.List.NonEmpty ( NonEmpty ) import Data.Foldable ( toList ) +import Data.Traversable ( for ) {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -470,7 +471,7 @@ commitFlexi DefaultFlexi tv zonked_kind ; return manyDataConTy } | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) - ; return (anyTypeOfKind zonked_kind) } + ; newZonkAnyType zonked_kind } | otherwise = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv) -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4) @@ -647,23 +648,25 @@ zonkTopDecls :: Bag EvBind -> LHsBinds GhcTc -> [LRuleDecl GhcTc] -> [LTcSpecPrag] -> [LForeignDecl GhcTc] + -> [PatSyn] -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc], [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords + [LRuleDecl GhcTc], + [PatSyn]) +zonkTopDecls ev_binds binds rules imp_specs fords pat_syns = initZonkEnv DefaultFlexi $ runZonkBndrT (zonkEvBinds ev_binds) $ \ ev_binds' -> runZonkBndrT (zonkRecMonoBinds binds) $ \ binds' -> -- Top level is implicitly recursive - do { rules' <- zonkRules rules - ; specs' <- zonkLTcSpecPrags imp_specs - ; fords' <- zonkForeignExports fords - ; ty_env <- zonkEnvIds <$> getZonkEnv - ; return (ty_env, ev_binds', binds', fords', specs', rules') } - + do { rules' <- zonkRules rules + ; specs' <- zonkLTcSpecPrags imp_specs + ; fords' <- zonkForeignExports fords + ; pat_syns' <- traverse zonkPatSyn pat_syns + ; ty_env <- zonkEnvIds <$> getZonkEnv + ; return (ty_env, ev_binds', binds', fords', specs', rules', pat_syns') } --------------------------------------------- zonkLocalBinds :: HsLocalBinds GhcTc @@ -1549,7 +1552,8 @@ zonk_pat (SumPat tys pat alt arity ) ; pat' <- zonkPat pat ; return (SumPat tys' pat' alt arity) } -zonk_pat p@(ConPat { pat_args = args +zonk_pat p@(ConPat { pat_con = L con_loc con + , pat_args = args , pat_con_ext = p'@(ConPatTc { cpt_tvs = tyvars , cpt_dicts = evs @@ -1568,8 +1572,15 @@ zonk_pat p@(ConPat { pat_args = args ; new_binds <- zonkTcEvBinds binds ; new_wrapper <- zonkCoFn wrapper ; new_args <- zonkConStuff args + ; new_con <- case con of + RealDataCon {} -> return con + -- Data constructors never contain metavariables: they are + -- fully zonked before we look at any value bindings. + PatSynCon ps -> PatSynCon <$> noBinders (zonkPatSyn ps) + -- Pattern synonyms can contain metavariables, see e.g. T26465c. ; pure $ p - { pat_args = new_args + { pat_con = L con_loc new_con + , pat_args = new_args , pat_con_ext = p' { cpt_arg_tys = new_tys , cpt_tvs = new_tyvars @@ -1615,14 +1626,14 @@ zonk_pat (InvisPat ty tp) ; return (InvisPat ty' tp) } zonk_pat (XPat ext) = case ext of - { ExpansionPat orig pat-> + { ExpansionPat orig pat -> do { pat' <- zonk_pat pat ; return $ XPat $ ExpansionPat orig pat' } ; CoPat co_fn pat ty -> - do { co_fn' <- zonkCoFn co_fn - ; pat' <- zonkPat (noLocA pat) - ; ty' <- noBinders $ zonkTcTypeToTypeX ty - ; return (XPat $ CoPat co_fn' (unLoc pat') ty') + do { co_fn' <- zonkCoFn co_fn + ; pat' <- zonk_pat pat + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (XPat $ CoPat co_fn' pat' ty') } } zonk_pat pat = pprPanic "zonk_pat" (ppr pat) @@ -1653,6 +1664,45 @@ zonkPats = traverse zonkPat {-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-} {-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-} +--------------------------- + +-- | Perform a final zonk-to-type for a pattern synonym. +-- +-- See Note [Metavariables in pattern synonyms] in GHC.Tc.TyCl.PatSyn. +zonkPatSyn :: PatSyn -> ZonkTcM PatSyn +zonkPatSyn + ps@( MkPatSyn + { psArgs = arg_tys + , psUnivTyVars = univ_tvs + , psReqTheta = req_theta + , psExTyVars = ex_tvs + , psProvTheta = prov_theta + , psResultTy = res_ty + , psMatcher = (matcherNm, matcherTy, matcherDummyArg) + , psBuilder = mbBuilder + }) = + runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> + do { req_theta' <- zonkTcTypesToTypesX req_theta + ; res_ty' <- zonkTcTypeToTypeX res_ty + ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> + do { prov_theta' <- zonkTcTypesToTypesX prov_theta + ; arg_tys' <- zonkTcTypesToTypesX arg_tys + ; matcherTy' <- zonkTcTypeToTypeX matcherTy + ; mbBuilder' <- for mbBuilder $ \ (builderNm, builderTy, builderDummyArg) -> + do { builderTy' <- zonkTcTypeToTypeX builderTy + ; return (builderNm, builderTy', builderDummyArg) } + ; return $ + ps + { psArgs = arg_tys' + , psUnivTyVars = univ_tvs' + , psReqTheta = req_theta' + , psExTyVars = ex_tvs' + , psProvTheta = prov_theta' + , psResultTy = res_ty' + , psMatcher = (matcherNm, matcherTy', matcherDummyArg) + , psBuilder = mbBuilder' + } } } + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -233,7 +233,7 @@ data HsBindLR idL idR var_rhs :: LHsExpr idR -- ^ Located only for consistency } - -- | Patterns Synonym Binding + -- | Pattern Synonym Binding | PatSynBind (XPatSynBind idL idR) (PatSynBind idL idR) ===================================== testsuite/tests/patsyn/should_compile/T26465b.hs ===================================== @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T26465b where + +-- Variant of T26465 which should be accepted + +f :: Eq a => a -> Maybe a +f _ = Nothing + +-- Monomorphism restriction bites +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0] +g = f + +pattern P x <- ( g -> Just x ) + +x = g (1 :: Int) ===================================== testsuite/tests/patsyn/should_compile/T26465c.hs ===================================== @@ -0,0 +1,45 @@ + +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} + +module T26465c where + +-- Rep-poly variant of T26465b + +import Data.Kind + ( Constraint ) +import GHC.Exts + ( TYPE, Int#, isTrue#, (>=#) ) + + +type HasP :: forall r. TYPE r -> Constraint +class HasP a where + getP :: a -> (# (# #) | (# #) #) + mk :: (# #) -> a + +instance HasP Int where + getP i = if i >= 0 then (# | (# #) #) else (# (# #) | #) + mk _ = 1 +instance HasP Int# where + getP i# = if isTrue# ( i# >=# 0# ) then (# | (# #) #) else (# (# #) | #) + mk _ = 1# + +g1 = getP +g2 = getP + +m1 = mk +m2 = mk + +-- NB: deliberately use no arguments to make this test harder (so that we run +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder'). +pattern P1 <- ( g1 -> (# | (# #) #) ) + where P1 = m1 (# #) +pattern P2 <- ( g2 -> (# | (# #) #) ) + where P2 = m2 (# #) + +y1 :: Int -> Int +y1 P1 = P1 + +y2 :: Int# -> Int# +y2 P2 = P2 ===================================== testsuite/tests/patsyn/should_compile/T26465d.hs ===================================== @@ -0,0 +1,28 @@ + +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} + +module T26465d where + +-- Should-fail variant of T26465c (but with -fdefer-type-errors) + +import Data.Kind + ( Constraint ) +import GHC.Exts + ( TYPE ) + +type HasP :: forall r. TYPE r -> Constraint +class HasP a where + getP :: a -> (# (# #) | (# #) #) + mk :: (# #) -> a + +g = getP +m = mk + +-- NB: deliberately use no arguments to make this test harder (so that we run +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder'). +pattern P1 <- ( g -> (# | (# #) #) ) + where P1 = m (# #) + +test P1 = P1 ===================================== testsuite/tests/patsyn/should_compile/T26465d.stderr ===================================== @@ -0,0 +1,10 @@ +T26465d.hs:20:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] + • No instance for ‘HasP a0’ arising from a use of ‘getP’ + • In the expression: getP + In an equation for ‘g’: g = getP + +T26465d.hs:21:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] + • No instance for ‘HasP a0’ arising from a use of ‘mk’ + • In the expression: mk + In an equation for ‘m’: m = mk + ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -73,6 +73,9 @@ test('T13752a', normal, compile, ['']) test('T13768', normal, compile, ['']) test('T14058', [extra_files(['T14058.hs', 'T14058a.hs'])], multimod_compile, ['T14058', '-v0']) +test('T26465b', normal, compile, ['']) +test('T26465c', normal, compile, ['']) +test('T26465d', normal, compile, ['-fdefer-type-errors']) test('T14326', normal, compile, ['']) test('T14380', normal, compile, ['']) test('T14394', normal, ghci_script, ['T14394.script']) ===================================== testsuite/tests/patsyn/should_fail/T26465.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T26465 where + +f :: Eq a => a -> Maybe a +f _ = Nothing + +-- Monomorphism restriction bites +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0] +g = f + +pattern P x <- ( g -> Just x ) ===================================== testsuite/tests/patsyn/should_fail/T26465.stderr ===================================== @@ -0,0 +1,15 @@ +T26465.hs:10:5: error: [GHC-39999] + • Ambiguous type variable ‘a0’ arising from a use of ‘f’ + prevents the constraint ‘(Eq a0)’ from being solved. + Relevant bindings include + g :: a0 -> Maybe a0 (bound at T26465.hs:10:1) + Probable fix: use a type annotation to specify what ‘a0’ should be. + Potentially matching instances: + instance Eq Ordering -- Defined in ‘GHC.Internal.Classes’ + instance Eq Integer -- Defined in ‘GHC.Internal.Bignum.Integer’ + ...plus 24 others + ...plus five instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + • In the expression: f + In an equation for ‘g’: g = f + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -35,6 +35,7 @@ test('T12165', normal, compile_fail, ['']) test('T12819', normal, compile_fail, ['']) test('UnliftedPSBind', normal, compile_fail, ['']) test('T15695', normal, compile, ['']) # It has -fdefer-type-errors inside +test('T26465', normal, compile_fail, ['']) test('T13349', normal, compile_fail, ['']) test('T13470', normal, compile_fail, ['']) test('T14112', normal, compile_fail, ['']) ===================================== testsuite/tests/th/T8761.stderr ===================================== @@ -123,29 +123,29 @@ T8761.hs:(71,1)-(105,39): Splicing declarations pattern Puep x y <- (MkExProv y, x) pattern T8761.P :: GHC.Internal.Types.Bool pattern T8761.Pe :: () => forall (a_0 :: *) . a_0 -> T8761.Ex -pattern T8761.Pu :: forall (a_0 :: *) . a_0 -> a_0 -pattern T8761.Pue :: forall (a_0 :: *) . () => forall (b_1 :: *) . - a_0 -> b_1 -> (a_0, T8761.Ex) -pattern T8761.Pur :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - a_0 -> [a_0] -pattern T8761.Purp :: forall (a_0 :: *) (b_1 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> ([a_0], T8761.UnivProv b_1) -pattern T8761.Pure :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - forall (b_1 :: *) . a_0 -> b_1 -> ([a_0], T8761.Ex) -pattern T8761.Purep :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => +pattern T8761.Pu :: forall (a0_0 :: *) . a0_0 -> a0_0 +pattern T8761.Pue :: forall (a0_0 :: *) . () => forall (b_1 :: *) . + a0_0 -> b_1 -> (a0_0, T8761.Ex) +pattern T8761.Pur :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + a0_0 -> [a0_0] +pattern T8761.Purp :: forall (a0_0 :: *) (b0_1 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + GHC.Internal.Show.Show b0_1 => + a0_0 -> b0_1 -> ([a0_0], T8761.UnivProv b0_1) +pattern T8761.Pure :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + forall (b_1 :: *) . a0_0 -> b_1 -> ([a0_0], T8761.Ex) +pattern T8761.Purep :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> ([a_0], T8761.ExProv) + a0_0 -> b_1 -> ([a0_0], T8761.ExProv) pattern T8761.Pep :: () => forall (a_0 :: *) . GHC.Internal.Show.Show a_0 => a_0 -> T8761.ExProv -pattern T8761.Pup :: forall (a_0 :: *) . () => GHC.Internal.Show.Show a_0 => - a_0 -> T8761.UnivProv a_0 -pattern T8761.Puep :: forall (a_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> (T8761.ExProv, a_0) +pattern T8761.Pup :: forall (a0_0 :: *) . () => GHC.Internal.Show.Show a0_0 => + a0_0 -> T8761.UnivProv a0_0 +pattern T8761.Puep :: forall (a0_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => + a0_0 -> b_1 -> (T8761.ExProv, a0_0) T8761.hs:(108,1)-(117,25): Splicing declarations do infos <- mapM reify View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c85c845dc5ad539bf28f1b8c5c1dbb3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c85c845dc5ad539bf28f1b8c5c1dbb3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
by Marge Bot (＠marge-bot) 18 Oct '25

18 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f85058d3 by Zubin Duggal at 2025-10-17T13:50:52+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 Metric Decrease: T9233 - - - - - 41 changed files: - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs - + testsuite/tests/ghc-api/T26264.hs - + testsuite/tests/ghc-api/T26264.stdout - testsuite/tests/ghc-api/all.T - testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr - testsuite/tests/overloadedrecflds/should_fail/T16745.stderr - testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr - testsuite/tests/perf/should_run/UniqLoop.hs - testsuite/tests/regalloc/regalloc_unit_tests.hs - testsuite/tests/simplCore/should_compile/rule2.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f85058d3361cc9030265c716d5d1b8e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f85058d3361cc9030265c716d5d1b8e… You're receiving this email because of your account on gitlab.haskell.org.

1 0