[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 3 commits: Implement `decode` in terms of `decodeStackWithIpe`
by Hannes Siebenhandl (＠fendor) 24 Jul '25
by Hannes Siebenhandl (＠fendor) 24 Jul '25
24 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
dd7d83e6 by fendor at 2025-07-24T16:42:07+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
d11ae9b3 by fendor at 2025-07-24T16:42:07+02:00
Remove stg_decodeStackzh
- - - - -
5436ac24 by fendor at 2025-07-24T16:42:07+02:00
Remove ghcHeap from list of toolTargets
- - - - -
15 changed files:
- hadrian/src/Rules/ToolArgs.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- 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
- 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:
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -160,7 +160,7 @@ toolTargets = [ cabalSyntax
, ghcPlatform
, ghcToolchain
, ghcToolchainBin
- , ghcHeap
+ -- , ghcHeap -- # depends on ghcInternal library
, ghci
, ghcPkg -- # executable
, haddock -- # depends on ghc library
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,3 +17,4 @@ 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*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
-getInfoTableAddrzh(P_ stack, W_ offsetWords) {
- P_ p, info;
+// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
+getInfoTableAddrszh(P_ stack, W_ offsetWords) {
+ P_ p, info_struct, info_entry;
p = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
- info = %GET_STD_INFO(UNTAG(p));
-
- return (info);
+ info_struct = %GET_STD_INFO(UNTAG(p));
+ info_entry = %GET_ENTRY(UNTAG(p));
+ return (info_struct, info_entry);
}
// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
=====================================
libraries/ghc-internal/cbits/StackCloningDecoding.cmm
=====================================
@@ -17,10 +17,3 @@ 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/jsbits/base.js
=====================================
@@ -1245,9 +1245,8 @@ 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$stg_decodeStackzh
+var h$stg_cloneMyStackzh
h$stg_cloneMyStackzh
- = h$stg_decodeStackzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,7 @@ import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack as ExecStack
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.
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
=====================================
@@ -15,34 +15,20 @@
-- @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, (# #) #)
@@ -205,64 +191,3 @@ 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
=====================================
@@ -13,7 +13,17 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
+ -- * High-level stack decoders
+ decode,
decodeStack,
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackFrameWithIpe,
+ prettyStackEntry,
)
where
@@ -23,7 +33,10 @@ 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
@@ -42,6 +55,7 @@ import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Heap.InfoTable
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.CloneStack
+import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
{- Note [Decoding the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -153,14 +167,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
-foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
+foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
-getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
+-- | 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# index =
- let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
- in peekItbl infoTablePtr
+ let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
+ in
+ (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#)
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack stackSnapshot# =
@@ -279,18 +296,63 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
(bitmapWordPointerness size bitmap)
unpackStackFrame :: StackFrameLocation -> IO StackFrame
-unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
- info <- getInfoTableOnStack stackSnapshot# index
+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 ->
+ (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
+ (StackFrame -> Maybe InfoProv -> IO a) ->
+ IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+ (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
+ (\info stack -> unpackUnderflowFrame info m_info_prov stack)
+ (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' :: StgInfoTable -> IO StackFrame
- unpackStackFrame' info =
+ unpackStackFrame' ::
+ StgInfoTable ->
+ (StgInfoTable -> StackSnapshot -> IO a) ->
+ (StackFrame -> IO a) ->
+ IO a
+ unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
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)
- pure
+ mkStackFrameResult
RetBCO
{ info_tbl = info,
bco = bco',
@@ -299,14 +361,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
RET_SMALL ->
let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
in
- pure $
+ mkStackFrameResult $
RetSmall
{ info_tbl = info,
stack_payload = payload'
}
RET_BIG -> do
payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
- pure $
+ mkStackFrameResult $
RetBig
{ info_tbl = info,
stack_payload = payload'
@@ -318,7 +380,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
if isArgGenBigRetFunType stackSnapshot# index == True
then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
- pure $
+ mkStackFrameResult $
RetFun
{ info_tbl = info,
retFunSize = retFunSize',
@@ -328,31 +390,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
UPDATE_FRAME ->
let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
in
- pure $
+ mkStackFrameResult $
UpdateFrame
{ info_tbl = info,
updatee = updatee'
}
CATCH_FRAME -> do
let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
- pure $
+ mkStackFrameResult $
CatchFrame
{ info_tbl = info,
handler = handler'
}
UNDERFLOW_FRAME -> do
let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
- stackClosure <- decodeStack nextChunk'
- pure $
- UnderflowFrame
- { info_tbl = info,
- nextChunk = stackClosure
- }
- STOP_FRAME -> pure $ StopFrame {info_tbl = info}
+ mkUnderflowResult info nextChunk'
+ STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
ATOMICALLY_FRAME -> do
let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
- pure $
+ mkStackFrameResult $
AtomicallyFrame
{ info_tbl = info,
atomicallyFrameCode = atomicallyFrameCode',
@@ -363,7 +420,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
in
- pure $
+ mkStackFrameResult $
CatchRetryFrame
{ info_tbl = info,
running_alt_code = running_alt_code',
@@ -374,7 +431,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
in
- pure $
+ mkStackFrameResult $
CatchStmFrame
{ info_tbl = info,
catchFrameCode = catchFrameCode',
@@ -393,6 +450,54 @@ 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
@@ -405,19 +510,31 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
--
-- See /Note [Decoding the stack]/.
decodeStack :: StackSnapshot -> IO StgStackClosure
-decodeStack (StackSnapshot stack#) = do
+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
info <- getInfoTableForStack stack#
case tipe info of
STACK -> do
- 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'
- }
+ let sfls = stackFrameLocations stack#
+ stack' <- mapM unpackFrame sfls
+ pure (info, stack')
_ -> error $ "Expected STACK closure, got " ++ show info
where
stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
@@ -428,3 +545,15 @@ decodeStack (StackSnapshot stack#) = do
go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Nothing = []
go (Just r) = r : go (advanceStackFrameLocation r)
+
+-- ----------------------------------------------------------------------------
+-- Pretty printing functions for stack entires, stack frames and provenance info
+-- ----------------------------------------------------------------------------
+
+prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
+prettyStackFrameWithIpe (_frame, mipe) =
+ (prettyStackEntry . toStackEntry) <$> mipe
+
+prettyStackEntry :: StackEntry -> String
+prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
+ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
rts/CloneStack.c
=====================================
@@ -26,11 +26,6 @@
#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;
@@ -112,94 +107,3 @@ 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,8 +15,6 @@ 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
=====================================
@@ -953,7 +953,6 @@ 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
=====================================
@@ -323,7 +323,7 @@ module Control.Exception.Backtrace where
type BacktraceMechanism :: *
data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
type Backtraces :: *
- data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
+ data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.Decode.StackEntry]}
collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
displayBacktraces :: Backtraces -> GHC.Internal.Base.String
getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -11703,7 +11703,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
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’
@@ -13164,7 +13164,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+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.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
=====================================
@@ -323,7 +323,7 @@ module Control.Exception.Backtrace where
type BacktraceMechanism :: *
data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
type Backtraces :: *
- data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
+ data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.Decode.StackEntry]}
collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
displayBacktraces :: Backtraces -> GHC.Internal.Base.String
getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -14738,7 +14738,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
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’
@@ -16196,7 +16196,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+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.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
=====================================
@@ -323,7 +323,7 @@ module Control.Exception.Backtrace where
type BacktraceMechanism :: *
data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
type Backtraces :: *
- data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
+ data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.Decode.StackEntry]}
collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
displayBacktraces :: Backtraces -> GHC.Internal.Base.String
getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -11959,7 +11959,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
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’
@@ -13436,7 +13436,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+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.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
=====================================
@@ -323,7 +323,7 @@ module Control.Exception.Backtrace where
type BacktraceMechanism :: *
data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
type Backtraces :: *
- data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
+ data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.Decode.StackEntry]}
collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
displayBacktraces :: Backtraces -> GHC.Internal.Base.String
getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -11703,7 +11703,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
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’
@@ -13164,7 +13164,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
+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.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/c4a847780285066cb679d94d462dfd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4a847780285066cb679d94d462dfd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
24 Jul '25
Matthew Pickering pushed new branch wip/t29090 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/t29090
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.10.3-backports] 11 commits: 9.10 hadrian can build with Cabal-3.12.1
by Zubin (＠wz1000) 24 Jul '25
by Zubin (＠wz1000) 24 Jul '25
24 Jul '25
Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC
Commits:
1e683e75 by Jens Petersen at 2025-07-24T19:43:04+05:30
9.10 hadrian can build with Cabal-3.12.1
fixes #25605
(cherry picked from commit 07f17b6ed1bb0ba7134ee8dfd992036e97552c94)
- - - - -
ed36fab9 by sheaf at 2025-07-24T19:43:04+05:30
Don't cache solved [W] HasCallStack constraints
This commit ensures we do not add solved Wanted constraints that mention
HasCallStack or HasExceptionContext constraints to the set of solved
Wanted dictionary constraints: caching them is invalid, because re-using
such cached dictionaries means using an old call-stack instead of
constructing a new one, as was reported in #25529.
Fixes #25529.
(cherry picked from commit 256ac29c8df4f17a1d50ea243408d506ebf395d6)
- - - - -
2d56479d by Zubin Duggal at 2025-07-24T19:43:04+05:30
In commit "Don't cache solved [W] HasCallStack constraints" (256ac29c8df4f17a1d50ea243408d506ebf395d6),
we attempt to use `tryM` to avoid errors when looking up certain known-key names like CallStack while
compiling ghc-prim and ghc-internal.
Unfortunately, `tryM` doesn't catch module lookup errors. This manifests as a failure to build ghc-prim
in `--make` mode on the GHC 9.10 branch.
Instead, we explicitly avoid doing lookups when we are compiling ghc-prim or ghc-internal instead of
relying on catching the exception.
- - - - -
c9ed6c63 by Zubin Duggal at 2025-07-24T19:43:04+05:30
Consider `PromotedDataCon` in `tyConStupidTheta`
Haddock checks data declarations for the stupid theta so as not to
pretty-print them as empty contexts. Type data declarations end up as
`PromotedDataCon`s by the time Haddock performs this check, causing a
panic. This commit extends `tyConStupidTheta` so that it returns an
empty list for `PromotedDataCon`s. This decision was guided by the fact
that type data declarations never have data type contexts (see (R1) in
Note [Type data declarations]).
Fixes #25739.
(cherry picked from commit 8d33d048dbe159a045a4c304fa92318365a3dfe2)
- - - - -
818e64c6 by Ryan Hendrickson at 2025-07-24T19:43:04+05:30
haddock: Preserve indentation in multiline examples
Intended for use with :{ :}, but doesn't look for those characters. Any
consecutive lines with birdtracks will only have initial whitespace
stripped up to the column of the first line.
(cherry picked from commit 2c73250494fd9f48ebda6d6fe72f0cd03182aff1)
- - - - -
9c546366 by Ryan Hendrickson at 2025-07-24T19:43:04+05:30
haddock: Parse math even after ordinary characters
Fixes a bug where math sections were not recognized if preceded by a
character that isn't special (like space or a markup character).
(cherry picked from commit b790d647c1ccdcc9aa8f166c3e0e42d0a5c29625)
- - - - -
010146ec by Ryan Hendrickson at 2025-07-24T19:43:04+05:30
haddock: Fix links to type operators
(cherry picked from commit a0adc30d892f14f543f39d5c45faccacbc28afb4)
- - - - -
18575c9f by Ryan Hendrickson at 2025-07-24T19:43:04+05:30
haddock: Document instances from other packages
When attaching instances to `Interface`s, it isn't enough just to look
for instances in the list of `Interface`s being processed. We also need
to look in the modules on which they depend, including those outside of
this package.
Fixes #25147.
Fixes #26079.
(cherry picked from commit a26243fde4680271712a3d774e17f6cd6da4a652)
- - - - -
fa3cd6ec by Zubin Duggal at 2025-07-24T19:43:04+05:30
haddock: Don't warn about missing link destinations for derived names.
Fixes #26114
(cherry picked from commit 5dabc718a04bfc4d277c5ff7f815ee3d6b9670cb)
- - - - -
0aebaa62 by Zubin Duggal at 2025-07-24T19:43:04+05:30
Bump haddock version to 2.31.3
- - - - -
ecbc5c95 by Zubin Duggal at 2025-07-24T19:43:04+05:30
Prepare 9.10.3 prerelease
- - - - -
26 changed files:
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Types.hs
- configure.ac
- + docs/users_guide/9.10.3-notes.rst
- hadrian/hadrian.cabal
- hadrian/src/Context.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Hadrian/Haskell/Cabal/Type.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/CabalReinstall.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Rules/Rts.hs
- hadrian/src/Settings/Builders/Ghc.hs
- testsuite/driver/testlib.py
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/driver/T20604/T20604.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/static-plugins.stdout
- + testsuite/tests/typecheck/should_run/T25529.hs
- + testsuite/tests/typecheck/should_run/T25529.stdout
- testsuite/tests/typecheck/should_run/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Core.Predicate (
-- Implicit parameters
isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
- isExceptionContextPred,
+ isExceptionContextPred, isExceptionContextTy,
isIPPred_maybe,
-- Evidence variables
@@ -39,7 +39,6 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
-import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
@@ -292,7 +291,7 @@ isExceptionContextPred cls tys
| otherwise
= Nothing
--- | Is a type a 'CallStack'?
+-- | Is a type an 'ExceptionContext'?
isExceptionContextTy :: Type -> Bool
isExceptionContextTy ty
| Just tc <- tyConAppTyCon_maybe ty
@@ -338,31 +337,38 @@ isCallStackTy ty
isIPLikePred :: Type -> Bool
-- Is `pred`, or any of its superclasses, an implicit parameter?
-- See Note [Local implicit parameters]
-isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred
-
-mentionsIP :: Type -> Class -> [Type] -> Bool
--- Is (cls tys) an implicit parameter with key `str_ty`, or
--- is any of its superclasses such at thing.
+isIPLikePred pred =
+ mentions_ip_pred initIPRecTc (const True) (const True) pred
+
+mentionsIP :: (Type -> Bool) -- ^ predicate on the string
+ -> (Type -> Bool) -- ^ predicate on the type
+ -> Class
+ -> [Type] -> Bool
+-- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
+--
+-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
+-- are both @True@,
+-- - or any superclass of @cls tys@ has this property.
+--
-- See Note [Local implicit parameters]
-mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys
-
-mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool
-mentions_ip rec_clss mb_str_ty cls tys
- | Just (str_ty', _) <- isIPPred_maybe cls tys
- = case mb_str_ty of
- Nothing -> True
- Just str_ty -> str_ty `eqType` str_ty'
+mentionsIP = mentions_ip initIPRecTc
+
+mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
+mentions_ip rec_clss str_cond ty_cond cls tys
+ | Just (str_ty, ty) <- isIPPred_maybe cls tys
+ = str_cond str_ty && ty_cond ty
| otherwise
- = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)
+ = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
| sc_sel_id <- classSCSelIds cls ]
-mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool
-mentions_ip_pred rec_clss mb_str_ty ty
+
+mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
+mentions_ip_pred rec_clss str_cond ty_cond ty
| Just (cls, tys) <- getClassPredTys_maybe ty
, let tc = classTyCon cls
, Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
else checkRecTc rec_clss tc
- = mentions_ip rec_clss' mb_str_ty cls tys
+ = mentions_ip rec_clss' str_cond ty_cond cls tys
| otherwise
= False -- Includes things like (D []) where D is
-- a Constraint-ranged family; #7785
@@ -429,7 +435,38 @@ Small worries (Sept 20):
* The superclass hunt stops when it encounters the same class again,
but in principle we could have the same class, differently instantiated,
and the second time it could have an implicit parameter
-I'm going to treat these as problems for another day. They are all exotic. -}
+I'm going to treat these as problems for another day. They are all exotic.
+
+Note [Using typesAreApart when calling mentionsIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call 'mentionsIP' in two situations:
+
+ (1) to check that a predicate does not contain any implicit parameters
+ IP str ty, for a fixed literal str and any type ty,
+ (2) to check that a predicate does not contain any HasCallStack or
+ HasExceptionContext constraints.
+
+In both of these cases, we want to be sure, so we should be conservative:
+
+ For (1), the predicate might contain an implicit parameter IP Str a, where
+ Str is a type family such as:
+
+ type family MyStr where MyStr = "abc"
+
+ To safeguard against this (niche) situation, instead of doing a simple
+ type equality check, we use 'typesAreApart'. This allows us to recognise
+ that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.
+
+ For (2), we similarly might have
+
+ type family MyCallStack where MyCallStack = CallStack
+
+ Again, here we use 'typesAreApart'. This allows us to see that
+
+ (?foo :: MyCallStack)
+
+ is indeed a CallStack constraint, hidden under a type family.
+-}
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -2659,6 +2659,7 @@ tyConStupidTheta :: TyCon -> [PredType]
tyConStupidTheta tc@(TyCon { tyConDetails = details })
| AlgTyCon {algTcStupidTheta = stupid} <- details = stupid
| PrimTyCon {} <- details = []
+ | PromotedDataCon {} <- details = []
| otherwise = pprPanic "tyConStupidTheta" (ppr tc)
-- | Extract the 'TyVar's bound by a vanilla type synonym
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Core.InstEnv ( DFunInstType )
import GHC.Core.Class
import GHC.Core.Predicate
import GHC.Core.Multiplicity ( scaledThing )
-import GHC.Core.Unify ( ruleMatchTyKiX )
+import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart )
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -105,21 +105,25 @@ updInertDicts :: DictCt -> TcS ()
updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
= do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
-> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
-- Update /both/ inert_cans /and/ inert_solved_dicts.
updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }
- | otherwise
+ inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
+ , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
+ | otherwise
-> return ()
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
where
- not_ip_for :: Type -> DictCt -> Bool
- not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not (mentionsIP str_ty cls tys)
+ -- Does this class constraint or any of its superclasses mention
+ -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
+ does_not_mention_ip_for :: Type -> DictCt -> Bool
+ does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
+ = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
+ -- See Note [Using typesAreApart when calling mentionsIP]
+ -- in GHC.Core.Predicate
canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt
-- Once-only processing of Dict constraints:
@@ -201,7 +205,7 @@ in two places:
* In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have
(?x :: ty) in the inert set and an identical (?x :: ty) as the work item.
-* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any
+* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
* Wrinkle (SIP1): we must be careful of superclasses. Consider
@@ -221,7 +225,7 @@ in two places:
An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
But it could happen for `class xx => D xx where ...` and the constraint D
(?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explorered.
+ implicit parameter constraints) is not well explored.
Example in #14218, and #23761
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -158,7 +158,7 @@ import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.Unify
-import GHC.Builtin.Names ( unsatisfiableClassNameKey )
+import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )
import GHC.Core.Type
import GHC.Core.TyCo.Rep as Rep
@@ -168,6 +168,7 @@ import GHC.Core.Predicate
import GHC.Core.Reduction
import GHC.Core.Class
import GHC.Core.TyCon
+import GHC.Core.Unify (typesAreApart)
import GHC.Types.Name
import GHC.Types.TyThing
@@ -177,13 +178,13 @@ import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
import GHC.Types.Unique.Set( elementOfUniqSet )
-import GHC.Unit.Module ( HasModule, getModule, extractModule )
+import GHC.Unit.Module ( HasModule, getModule, extractModule, primUnit, moduleUnit, ghcInternalUnit, bignumUnit)
import qualified GHC.Rename.Env as TcM
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
-import GHC.Utils.Misc (HasDebugCallStack)
+import GHC.Utils.Misc (HasDebugCallStack, (<||>))
import GHC.Data.Bag as Bag
import GHC.Data.Pair
@@ -478,14 +479,92 @@ getSafeOverlapFailures
updSolvedDicts :: InstanceWhat -> DictCt -> TcS ()
-- Conditionally add a new item in the solved set of the monad
-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
-updSolvedDicts what dict_ct@(DictCt { di_ev = ev })
+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
| isWanted ev
, instanceReturnsDictCon what
- = do { traceTcS "updSolvedDicts:" $ ppr dict_ct
+ = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
+ ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
+ ; let contains_callstack_or_exceptionCtx =
+ mentionsIP
+ (const True)
+ -- NB: the name of the call-stack IP is irrelevant
+ -- e.g (?foo :: CallStack) counts!
+ (is_callstack <||> is_exceptionCtx)
+ cls tys
+ -- See Note [Don't add HasCallStack constraints to the solved set]
+ ; unless contains_callstack_or_exceptionCtx $
+ do { traceTcS "updSolvedDicts:" $ ppr dict_ct
; updInertSet $ \ ics ->
- ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } }
+ ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }
+ } }
| otherwise
= return ()
+ where
+
+ -- Return a predicate that decides whether a type is CallStack
+ -- or ExceptionContext, accounting for e.g. type family reduction, as
+ -- per Note [Using typesAreApart when calling mentionsIP].
+ --
+ -- See Note [Using isCallStackTy in mentionsIP].
+ is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
+ is_tyConTy is_eq tc_name
+ = do { mb_tc <- wrapTcS $ do
+ mod <- tcg_mod <$> TcM.getGblEnv
+ if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]
+ then return Nothing
+ else Just <$> TcM.tcLookupTyCon tc_name
+ ; case mb_tc of
+ Just tc ->
+ return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))
+ Nothing ->
+ return is_eq
+ }
+
+{- Note [Don't add HasCallStack constraints to the solved set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not add solved Wanted dictionaries that mention HasCallStack constraints
+to the solved set, or we might fail to accumulate the proper call stack, as was
+reported in #25529.
+
+Recall that HasCallStack constraints (and the related HasExceptionContext
+constraints) are implicit parameter constraints, and are accumulated as per
+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.
+
+When we solve a Wanted that contains a HasCallStack constraint, we don't want
+to cache the result, because re-using that solution means re-using the call-stack
+in a different context!
+
+See also Note [Shadowing of implicit parameters], which deals with a similar
+problem with Given implicit parameter constraints.
+
+Note [Using isCallStackTy in mentionsIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To implement Note [Don't add HasCallStack constraints to the solved set],
+we need to check whether a constraint contains a HasCallStack or HasExceptionContext
+constraint. We do this using the 'mentionsIP' function, but as per
+Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
+
+ mentionsIP
+ (const True) -- (ignore the implicit parameter string)
+ (isCallStackTy <||> isExceptionContextTy)
+
+because this does not account for e.g. a type family that reduces to CallStack.
+The predicate we want to use instead is:
+
+ \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)
+
+However, this is made difficult by the fact that CallStack and ExceptionContext
+are not wired-in types; they are only known-key. This means we must look them
+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle
+of typechecking ghc-internal and these data-types have not been typechecked yet!
+
+In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'
+logic.
+
+Note that it would be somewhat painful to wire-in ExceptionContext: at the time
+of writing (March 2025), this would require wiring in the ExceptionAnnotation
+class, as well as SomeExceptionAnnotation, which is a data type with existentials.
+-}
getSolvedDicts :: TcS (DictMap DictCt)
getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }
=====================================
compiler/GHC/Tc/Solver/Types.hs
=====================================
@@ -166,7 +166,7 @@ Suppose f :: HasCallStack => blah. Then
IP "callStack" CallStack
See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by
+* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by
pushing the call-site info on the stack, and changing the CtOrigin
to record that has been done.
Bind: s1 = pushCallStack <site-info> s2
=====================================
configure.ac
=====================================
@@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.10.2], [glasgow-ha
AC_CONFIG_MACRO_DIRS([m4])
# Set this to YES for a released version, otherwise NO
-: ${RELEASE=YES}
+: ${RELEASE=NO}
# The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line
# above. If this is not a released version, then we will append the
=====================================
docs/users_guide/9.10.3-notes.rst
=====================================
@@ -0,0 +1,165 @@
+.. _release-9-10-3:
+
+Version 9.10.3
+===============
+The significant changes to the various parts of the compiler are listed in the
+following sections. See the `migration guide
+<https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.10>`_ on the GHC Wiki
+for specific guidance on migrating programs to this release.
+
+
+Compiler
+~~~~~~~~
+
+- Don't cache solved [W] HasCallStack constraints to avoid re-using old
+ call-stacks instead of constructing new ones. (:ghc-ticket:`25529`)
+
+- Fix EmptyCase panic in tcMatches when \case{} is checked against a function
+ type preceded by invisible forall. (:ghc-ticket:`25960`)
+
+- Fix panic triggered by combination of \case{} and forall t ->. (:ghc-ticket:`25004`)
+
+- Fix GHC.SysTools.Ar archive member size writing logic that was emitting wrong
+ archive member sizes in headers. (:ghc-ticket:`26120`, :ghc-ticket:`22586`)
+
+- Fix multiple bugs in name resolution of subordinate import lists related to
+ type namespace specifiers and hiding clauses. (:ghc-ticket:`22581`, :ghc-ticket:`25983`, :ghc-ticket:`25984`, :ghc-ticket:`25991`)
+
+- Use mkTrAppChecked in ds_ev_typeable to avoid false negatives for type
+ equality involving function types. (:ghc-ticket:`25998`)
+
+- Fix bytecode generation for ``tagToEnum# <LITERAL>``. (:ghc-ticket:`25975`)
+
+- Don't report used duplicate record fields as unused. (:ghc-ticket:`24035`)
+
+- Propagate long distance info to guarded let binds for better pattern-match
+ checking warnings. (:ghc-ticket:`25749`)
+
+- Prevent incorrect unpacking optimizations for GADTs with multiple constructors. (:ghc-ticket:`25672`)
+
+- Introduce a separate argument limit for forced specs via SPEC argument with
+ warning when limit is exceeded. (:ghc-ticket:`25197`)
+
+Build system and packaging
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- 9.10 hadrian can build with Cabal-3.12.1. (:ghc-ticket:`25605`)
+
+- GHC settings: always unescape escaped spaces to fix handling of spaces in
+ executable paths. (:ghc-ticket:`25204`)
+
+Native code generator backend
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- x86 NCG: Fix code generation of bswap64 on i386. (:ghc-ticket:`25601`)
+
+- AArch64 NCG: Fix sub-word arithmetic right shift by zero-extending sub-word
+ values. (:ghc-ticket:`26061`)
+
+- NCG: AArch64 - Add -finter-module-far-jumps flag for modules with far jumps
+ outside the current module. (:ghc-ticket:`24648`)
+
+LLVM backend
+~~~~~~~~~~~~
+
+- LLVM: fix typo in padLiveArgs that was incorrectly computing too many padding
+ registers causing segfaults. (:ghc-ticket:`25770`, :ghc-ticket:`25773`)
+
+- llvmGen: Fix linkage of built-in arrays to use Appending linkage instead of
+ Internal. (:ghc-ticket:`25769`)
+
+- llvmGen: Fix built-in variable predicate to check for `@llvm` rather than
+ `$llvm`.
+
+WebAssembly backend
+~~~~~~~~~~~~~~~~~~~
+
+- wasm: use primitive opcodes for fabs and sqrt operations.
+
+Runtime system
+~~~~~~~~~~~~~~
+
+- rts: Implement WEAK EXTERNAL undef redirection by target symbol name.
+
+- rts: Handle API set symbol versioning conflicts.
+
+- rts: fix rts_clearMemory logic when sanity checks are enabled. (:ghc-ticket:`26011`)
+
+- rts/linker: Improve efficiency of proddable blocks structure by using binary
+ search instead of linked lists for better performance with split sections. (:ghc-ticket:`26009`)
+
+- rts/linker/PEi386: Don't repeatedly load DLLs by maintaining a hash-set of
+ loaded DLL names. (:ghc-ticket:`26009`, :ghc-ticket:`26052`)
+
+- rts/linker: Don't fail due to RTLD_NOW by attempting eager binding first,
+ then reverting to lazy binding on failure. (:ghc-ticket:`25943`)
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+- base: Expose Backtraces constructor and fields. (:ghc-ticket:`26049`)
+
+- base: Note strictness changes made in 4.16.0.0. (:ghc-ticket:`25886`)
+
+- Fix bugs in ``integerRecipMod`` and ``integerPowMod`` return values. (:ghc-ticket:`26017`)
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+- perf: Replace uses of genericLength with strictGenericLength to reduce time
+ spent in 'assembleBCOs' and allocations. (:ghc-ticket:`25706`)
+
+Build tools
+~~~~~~~~~~~
+
+- configure: Drop probing of ld.gold since `gold` has been dropped from
+ binutils-2.44. (:ghc-ticket:`25716`)
+
+- get-win32-tarballs.py: List tarball files to be downloaded if we cannot find
+ them. (:ghc-ticket:`25929`)
+
+- hp2ps Utilities.c: include stdlib.h instead of extern malloc and realloc.
+
+Included libraries
+~~~~~~~~~~~~~~~~~~
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/stm/stm.cabal: Dependency of ``haskeline`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
\ No newline at end of file
=====================================
hadrian/hadrian.cabal
=====================================
@@ -152,7 +152,7 @@ executable hadrian
, TypeOperators
other-extensions: MultiParamTypeClasses
, TypeFamilies
- build-depends: Cabal >= 3.10 && < 3.11
+ build-depends: Cabal (>= 3.10 && < 3.11) || (>= 3.12.1 && < 3.13)
, base >= 4.11 && < 5
, bytestring >= 0.10 && < 0.13
, containers >= 0.5 && < 0.8
=====================================
hadrian/src/Context.hs
=====================================
@@ -9,7 +9,7 @@ module Context (
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir,
pkgHaddockFile, pkgRegisteredLibraryFile, pkgRegisteredLibraryFileName,
pkgLibraryFile, pkgGhciLibraryFile,
- pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir,
+ pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir, distDynDir,
haddockStatsFilesDir
) where
@@ -20,7 +20,8 @@ import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Oracles.Setting
import GHC.Toolchain.Target (Target(..))
-import GHC.Platform.ArchOS
+import Hadrian.Oracles.Cabal
+import Hadrian.Haskell.Cabal.Type
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
@@ -62,12 +63,15 @@ libPath Context {..} = buildRoot <&> (-/- (stageString stage -/- "lib"))
--
-- We preform some renaming to accommodate Cabal's slightly different naming
-- conventions (see 'cabalOsString' and 'cabalArchString').
-distDir :: Stage -> Action FilePath
-distDir st = do
- version <- ghcVersionStage st
- targetOs <- cabalOsString . stringEncodeOS . archOS_OS . tgtArchOs <$> targetStage st
- targetArch <- cabalArchString . stringEncodeArch . archOS_arch . tgtArchOs <$> targetStage st
- return $ targetArch ++ "-" ++ targetOs ++ "-ghc-" ++ version
+distDir :: Context -> Action FilePath
+distDir c = do
+ cd <- readContextData c
+ return (contextLibdir cd)
+
+distDynDir :: Context -> Action FilePath
+distDynDir c = do
+ cd <- readContextData c
+ return (contextDynLibdir cd)
pkgFileName :: Context -> Package -> String -> String -> Action FilePath
pkgFileName context package prefix suffix = do
@@ -104,13 +108,12 @@ pkgHaddockFile Context {..} = do
-- @_build/stage1/lib/x86_64-linux-ghc-8.9.0/array-0.5.1.0/libHSarray-0.5.4.0.a@
pkgRegisteredLibraryFile :: Context -> Action FilePath
pkgRegisteredLibraryFile context@Context {..} = do
- libDir <- libPath context
- pkgId <- pkgUnitId stage package
fileName <- pkgRegisteredLibraryFileName context
- distDir <- distDir stage
+ distDir <- distDir context
+ distDynDir <- distDynDir context
return $ if Dynamic `wayUnit` way
- then libDir -/- distDir -/- fileName
- else libDir -/- distDir -/- pkgId -/- fileName
+ then distDynDir -/- fileName
+ else distDir -/- fileName
-- | Just the final filename portion of pkgRegisteredLibraryFile
pkgRegisteredLibraryFileName :: Context -> Action FilePath
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -254,6 +254,7 @@ resolveContextData context@Context {..} = do
pdi <- liftIO $ getHookedBuildInfo [pkgPath package, cPath -/- "build"]
let pd' = C.updatePackageDescription pdi (C.localPkgDescr lbi)
lbi' = lbi { C.localPkgDescr = pd' }
+ pkgDbPath <- packageDbPath (PackageDbLoc stage iplace)
-- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
-- See: https://github.com/snowleopard/hadrian/issues/548
@@ -302,6 +303,8 @@ resolveContextData context@Context {..} = do
| takeExtension fp `elem` [".cpp", ".cxx", ".c++"]= CppMain
| otherwise = CMain
+ install_dirs = absoluteInstallDirs pd' lbi' (CopyToDb pkgDbPath)
+
main_src = fmap (first C.display) mainIs
cdata = ContextData
{ dependencies = deps
@@ -343,7 +346,10 @@ resolveContextData context@Context {..} = do
, depLdOpts = forDeps Installed.ldOptions
, buildGhciLib = C.withGHCiLib lbi'
, frameworks = C.frameworks buildInfo
- , packageDescription = pd' }
+ , packageDescription = pd'
+ , contextLibdir = libdir install_dirs
+ , contextDynLibdir = dynlibdir install_dirs
+ }
in return cdata
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Type.hs
=====================================
@@ -70,6 +70,10 @@ data ContextData = ContextData
, buildGhciLib :: Bool
, frameworks :: [String]
, packageDescription :: PackageDescription
+ -- The location where normal library files go
+ , contextLibdir :: FilePath
+ -- The location where dynamic libraries go
+ , contextDynLibdir :: FilePath
} deriving (Eq, Generic, Show, Typeable)
instance Binary PackageData
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -146,15 +146,12 @@ bindistRules = do
phony "binary-dist-dir" $ do
version <- setting ProjectVersion
targetPlatform <- setting TargetPlatformFull
- distDir <- Context.distDir Stage1
- rtsDir <- pkgUnitId Stage1 rts
- -- let rtsDir = "rts"
+ distDir <- Context.distDir (vanillaContext Stage1 rts)
let ghcBuildDir = root -/- stageString Stage1
bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty
ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform
- rtsIncludeDir = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
- -/- "include"
+ rtsIncludeDir = distDir -/- "include"
-- We 'need' all binaries and libraries
all_pkgs <- stagePackages Stage1
=====================================
hadrian/src/Rules/CabalReinstall.hs
=====================================
@@ -10,7 +10,6 @@ import Utilities
import qualified System.Directory.Extra as IO
import Data.Either
import Rules.BinaryDist
-import Hadrian.Haskell.Cabal (pkgUnitId)
import Oracles.Setting
{-
@@ -53,13 +52,10 @@ cabalBuildRules = do
iserv_targets <- if cross then pure [] else iservBins
need (lib_targets ++ (map (\(_, p) -> p) (bin_targets ++ iserv_targets)))
- distDir <- Context.distDir Stage1
- rtsDir <- pkgUnitId Stage1 rts
+ distDir <- Context.distDir (vanillaContext Stage1 rts)
-- let rtsDir = "rts"
- let ghcBuildDir = root -/- stageString Stage1
- rtsIncludeDir = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
- -/- "include"
+ let rtsIncludeDir = distDir -/- "include"
libdir <- liftIO . IO.makeAbsolute =<< stageLibPath Stage1
work_dir <- liftIO $ IO.makeAbsolute $ root -/- "stage-cabal"
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -182,11 +182,12 @@ buildConfFinal rs context@Context {..} _conf = do
--
-- so that if any change ends up modifying a library (but not its .conf
-- file), we still rebuild things that depend on it.
- dir <- (-/-) <$> libPath context <*> distDir stage
+ dir <- distDir context
+ dyndir <- distDynDir context
pkgid <- pkgUnitId stage package
files <- liftIO $
- (++) <$> getDirectoryFilesIO "." [dir -/- "*libHS"++pkgid++"*"]
- <*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
+ (++) <$> getDirectoryFilesIO "." [dyndir -/- "*libHS"++pkgid++"*"]
+ <*> getDirectoryFilesIO "." [dir -/- "**"]
produces files
buildConfInplace :: [(Resource, Int)] -> Context -> FilePath -> Action ()
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -154,10 +154,9 @@ needRtsSymLinks :: Stage -> Set.Set Way -> Action ()
needRtsSymLinks stage rtsWays
= forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do
let ctx = Context stage rts way Final
- libPath <- libPath ctx
- distDir <- distDir stage
+ distDir <- distDynDir ctx
rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
- need [removeRtsDummyVersion (libPath </> distDir </> rtsLibFile)]
+ need [removeRtsDummyVersion (distDir </> rtsLibFile)]
prefix, versionlessPrefix :: String
versionlessPrefix = "libHSrts"
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -98,9 +98,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
-- Relative path from the output (rpath $ORIGIN).
originPath <- dropFileName <$> getOutput
context <- getContext
- libPath' <- expr (libPath context)
- st <- getStage
- distDir <- expr (Context.distDir st)
+ distPath <- expr (Context.distDynDir context)
useSystemFfi <- expr (flag UseSystemFfi)
buildPath <- getBuildPath
@@ -112,7 +110,6 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
let
dynamic = Dynamic `wayUnit` way
- distPath = libPath' -/- distDir
originToLibsDir = makeRelativeNoSysLink originPath distPath
rpath
-- Programs will end up in the bin dir ($ORIGIN) and will link to
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1493,7 +1493,7 @@ async def do_test(name: TestName,
dst_makefile = in_testdir('Makefile')
if src_makefile.exists():
makefile = src_makefile.read_text(encoding='UTF-8')
- makefile = re.sub('TOP=.*', 'TOP=%s' % config.top, makefile, 1)
+ makefile = re.sub('TOP=.*', 'TOP=%s' % config.top, makefile, count=1)
dst_makefile.write_text(makefile, encoding='UTF-8')
if opts.pre_cmd:
=====================================
testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
=====================================
@@ -13,13 +13,13 @@ Building library 'q' instantiated with
for bkpcabal08-0.1.0.0...
[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
-[4 of 4] Instantiating bkpcabal08-0.1.0.0-5O1mUtZZLBeDZEqqtwJcCj-p
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-Asivy2QkF0WEbGENiw5nyj-p
Preprocessing library 'q' for bkpcabal08-0.1.0.0...
Building library 'q' instantiated with
- A = bkpcabal08-0.1.0.0-DlVb5PcmUolGCHYbfTL7EP-impl:A
- B = bkpcabal08-0.1.0.0-DlVb5PcmUolGCHYbfTL7EP-impl:B
+ A = bkpcabal08-0.1.0.0-BznDTmYyvWf7fdEdPEncB4-impl:A
+ B = bkpcabal08-0.1.0.0-BznDTmYyvWf7fdEdPEncB4-impl:B
for bkpcabal08-0.1.0.0...
-[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-LFiTKyjPqyn9yyuysCoVKg-q+5IA1jA4bEzCFcXtraqAC38/A.o ) [Prelude package changed]
-[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-LFiTKyjPqyn9yyuysCoVKg-q+5IA1jA4bEzCFcXtraqAC38/B.o ) [Prelude package changed]
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-BOgmYfE3t0l9LsOUH0dl5H-q+sLNLgjkt61DMZK9wGbx81/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-BOgmYfE3t0l9LsOUH0dl5H-q+sLNLgjkt61DMZK9wGbx81/B.o ) [Prelude package changed]
Preprocessing library 'r' for bkpcabal08-0.1.0.0...
Building library 'r' for bkpcabal08-0.1.0.0...
=====================================
testsuite/tests/driver/T20604/T20604.stdout
=====================================
@@ -1,11 +1,10 @@
A1
A
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-prim-0.10.0-inplace-ghc9.9.20230815.so" 1403aed32fb9af243c4cc949007c846c
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-bignum-1.3-inplace-ghc9.9.20230815.so" 54293f8faab737bac998f6e1a1248db8
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-internal-0.1.0.0-inplace-ghc9.9.20230815.so" a5c0e962d84d9044d44df4698becddcc
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSbase-4.19.0.0-inplace-ghc9.9.20230815.so" 4a90ed136fe0f89e5d0360daded517bd
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-boot-th-9.9-inplace-ghc9.9.20230815.so" e338655f71b1d37fdfdd2504b7de6e76
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSarray-0.5.6.0-inplace-ghc9.9.20230815.so" 6943478e8adaa043abf7a2b38dd435a2
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSdeepseq-1.5.0.0-inplace-ghc9.9.20230815.so" 9974eb196694990ac6bb3c2591405de0
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSpretty-1.1.3.6-inplace-ghc9.9.20230815.so" 1eefc21514f5584086f62b70aa554b7d
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHStemplate-haskell-2.21.0.0-inplace-ghc9.9.20230815.so" f85c86eb94dcce1eacd739b6e991ba2d
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-prim-0.12.0-inplace-ghc9.10.2.20250724.so" 0b7cbf5659e1fd221ea306e2da08c7d3
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-bignum-1.3-inplace-ghc9.10.2.20250724.so" 1c29a409bcfbc31a3cfc2ded7c1d5530
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-internal-9.1002.0-inplace-ghc9.10.2.20250724.so" 9606aee1cbbee934848aa85568563754
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSbase-4.20.1.0-inplace-ghc9.10.2.20250724.so" 5d1ab384becff6d4b20bae121d55fbc8
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-boot-th-9.10.2.20250724-inplace-ghc9.10.2.20250724.so" 930b5206ff48d75ba522e582262695a8
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSdeepseq-1.5.2.0-inplace-ghc9.10.2.20250724.so" db23e7880c9a9fee0d494b48294c3487
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSpretty-1.1.3.6-inplace-ghc9.10.2.20250724.so" ad484cfb103f02509b1be6abcf2a402f
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHStemplate-haskell-2.22.0.0-inplace-ghc9.10.2.20250724.so" 50b2cb166e6e5293c24be374ffac2ade
=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -27,12 +27,12 @@ instance [safe] Eq w => Eq (Maybe w)
-- Defined in ‘GHC.Internal.Maybe’
instance GHC.Internal.Generics.Generic [w]
-- Defined in ‘GHC.Internal.Generics’
-instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
-instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
instance Eq w => Eq [w] -- Defined in ‘GHC.Classes’
instance Ord w => Ord [w] -- Defined in ‘GHC.Classes’
instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
+instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
+instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
instance [safe] MyShow w => MyShow [w]
-- Defined at ghci064.hs:8:10
instance GHC.Internal.Generics.Generic [T]
=====================================
testsuite/tests/plugins/plugins10.stdout
=====================================
@@ -7,6 +7,8 @@ interfacePlugin: GHC.Internal.Float
interfacePlugin: GHC.Prim.Ext
interfacePlugin: Language.Haskell.TH.Syntax
typeCheckPlugin (rn)
+interfacePlugin: GHC.Internal.Stack.Types
+interfacePlugin: GHC.Internal.Exception.Context
typeCheckPlugin (tc)
parsePlugin(a)
typeCheckPlugin (rn)
=====================================
testsuite/tests/plugins/static-plugins.stdout
=====================================
@@ -8,6 +8,8 @@ interfacePlugin: GHC.Internal.System.IO
interfacePlugin: GHC.Types
interfacePlugin: GHC.Internal.Show
typeCheckPlugin (rn)
+interfacePlugin: GHC.Internal.Stack.Types
+interfacePlugin: GHC.Internal.Exception.Context
interfacePlugin: GHC.Internal.TopHandler
typeCheckPlugin (tc)
interfacePlugin: GHC.CString
=====================================
testsuite/tests/typecheck/should_run/T25529.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+
+module Main where
+
+import GHC.Stack (HasCallStack, CallStack, SrcLoc(srcLocStartLine, srcLocStartCol), callStack, getCallStack)
+
+main :: IO ()
+main =
+ let ?myImplicitParam = ()
+ in run action
+
+type MyConstraints = (HasCallStack, ?myImplicitParam :: ())
+
+action :: MyConstraints => IO ()
+action = run $ pure ()
+
+-- | Print the current call stack and then run an action.
+run ::
+ MyConstraints =>
+ IO a ->
+ IO a
+run action = do
+ let prettyCallStack = unlines $ map prettyCallStackEntry $ getCallStack callStack
+ prettyCallStackEntry (name, loc) =
+ name
+ <> ", called at "
+ <> show (srcLocStartLine loc)
+ <> ":"
+ <> show (srcLocStartCol loc)
+ putStrLn "============================================================"
+ putStrLn prettyCallStack
+ action
=====================================
testsuite/tests/typecheck/should_run/T25529.stdout
=====================================
@@ -0,0 +1,7 @@
+============================================================
+run, called at 11:7
+
+============================================================
+run, called at 16:10
+action, called at 11:11
+
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -170,6 +170,7 @@ test('T22510', normal, compile_and_run, [''])
test('T21973a', [exit_code(1)], compile_and_run, [''])
test('T21973b', normal, compile_and_run, [''])
test('T23761', normal, compile_and_run, [''])
+test('T25529', normal, compile_and_run, [''])
test('T23761b', normal, compile_and_run, [''])
test('T17594e', normal, compile_and_run, [''])
test('T25998', normal, compile_and_run, [''])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit f6116257ff838bb0b9def2c49d2f629756527ad2
+Subproject commit 00ac9eec76037ebf4e9b0b84f50675449edc5f51
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b6f36b2caa704c16d90183c02e2af…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b6f36b2caa704c16d90183c02e2af…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Include the rendered message in -fdiagnostics-as-json output
by Marge Bot (＠marge-bot) 24 Jul '25
by Marge Bot (＠marge-bot) 24 Jul '25
24 Jul '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d046b5ab by Simon Hengel at 2025-07-24T06:12:05-04:00
Include the rendered message in -fdiagnostics-as-json output
This implements #26173.
- - - - -
d2b89603 by Ben Gamari at 2025-07-24T06:12:47-04:00
rts/Interpreter: Factor out ctoi tuple info tables into data
Instead of a massive case let's put this into data which we can reuse
elsewhere.
- - - - -
8d3ce71a by Sebastian Graf at 2025-07-24T09:48:46-04:00
CprAnal: Detect recursive newtypes (#25944)
While `cprTransformDataConWork` handles recursive data con workers, it
did not detect the case when a newtype is responsible for the recursion.
This is now detected in the `Cast` case of `cprAnal`.
The same reproducer made it clear that `isRecDataCon` lacked congruent
handling for `AppTy` and `CastTy`, now fixed.
Furthermore, the new repro case T25944 triggered this bug via an
infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`.
While it should be much less likely to trigger such an infinite loop now
that `isRecDataCon` has been fixed, I made sure to abort the loop after
10 iterations and emitting a warning instead.
Fixes #25944.
- - - - -
c8c9416e by Sylvain Henry at 2025-07-24T09:49:08-04:00
STM: don't create a transaction in the rhs of catchRetry# (#26028)
We don't need to create a transaction for the rhs of (catchRetry#)
because contrary to the lhs we don't need to abort it on retry. Moreover
it is particularly harmful if we have code such as (#26028):
let cN = readTVar vN >> retry
tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...))
atomically tree
Because it will stack transactions for the rhss and the read-sets of all
the transactions will be iteratively merged in O(n^2) after the
execution of the most nested retry.
- - - - -
20 changed files:
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/9.14.1-notes.rst
- + docs/users_guide/diagnostics-as-json-schema-1_2.json
- docs/users_guide/using.rst
- rts/Interpreter.c
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- + testsuite/tests/cpranal/sigs/T25944.hs
- + testsuite/tests/cpranal/sigs/T25944.stderr
- testsuite/tests/cpranal/sigs/all.T
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
- + testsuite/tests/lib/stm/T26028.hs
- + testsuite/tests/lib/stm/T26028.stdout
- + testsuite/tests/lib/stm/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiWayIf #-}
-- | Constructed Product Result analysis. Identifies functions that surely
-- return heap-allocated records on every code path, so that we can eliminate
@@ -22,12 +23,15 @@ import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.MemoFun
+import GHC.Core
import GHC.Core.FamInstEnv
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Utils
-import GHC.Core
+import GHC.Core.Coercion
+import GHC.Core.Reduction
import GHC.Core.Seq
+import GHC.Core.TyCon
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Data.Graph.UnVar -- for UnVarSet
@@ -216,9 +220,13 @@ cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact
cprAnal' _ (Coercion co) = (topCprType, Coercion co)
cprAnal' env (Cast e co)
- = (cpr_ty, Cast e' co)
+ = (cpr_ty', Cast e' co)
where
(cpr_ty, e') = cprAnal env e
+ cpr_ty'
+ | cpr_ty == topCprType = topCprType -- cheap case first
+ | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]
+ | otherwise = cpr_ty
cprAnal' env (Tick t e)
= (cpr_ty, Tick t e')
@@ -391,6 +399,19 @@ cprTransformDataConWork env con args
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = 10
+isRecNewTyConApp :: AnalEnv -> Type -> Bool
+-- See Note [CPR for recursive newtype constructors]
+isRecNewTyConApp env ty
+ --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined
+ | Just (tc, tc_args) <- splitTyConApp_maybe ty =
+ if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args
+ -> isRecNewTyConApp env rhs
+ | Just dc <- newTyConDataCon_maybe tc
+ -> ae_rec_dc env dc == DefinitelyRecursive
+ | otherwise
+ -> False
+ | otherwise = False
+
--
-- * Bindings
--
@@ -414,12 +435,18 @@ cprFix orig_env orig_pairs
| otherwise = orig_pairs
init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
+ -- If fixed-point iteration does not yield a result we use this instead
+ -- See Note [Safe abortion in the fixed-point iteration]
+ abort :: (AnalEnv, [(Id,CoreExpr)])
+ abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ]
+
-- The fixed-point varies the idCprSig field of the binders and and their
-- entries in the AnalEnv, and terminates if that annotation does not change
-- any more.
loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
loop n env pairs
| found_fixpoint = (reset_env', pairs')
+ | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort
| otherwise = loop (n+1) env' pairs'
where
-- In all but the first iteration, delete the virgin flag
@@ -519,8 +546,9 @@ cprAnalBind env id rhs
-- possibly trim thunk CPR info
rhs_ty'
-- See Note [CPR for thunks]
- | stays_thunk = trimCprTy rhs_ty
- | otherwise = rhs_ty
+ | rhs_ty == topCprType = topCprType -- cheap case first
+ | stays_thunk = trimCprTy rhs_ty
+ | otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
sig = mkCprSigForArity (idArity id) rhs_ty'
-- See Note [OPAQUE pragma]
@@ -639,7 +667,7 @@ data AnalEnv
, ae_fam_envs :: FamInstEnvs
-- ^ Needed when expanding type families and synonyms of product types.
, ae_rec_dc :: DataCon -> IsRecDataConResult
- -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
+ -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType
}
instance Outputable AnalEnv where
@@ -1042,10 +1070,11 @@ Eliminating the shared 'c' binding in the process. And then
What can we do about it?
- A. Don't CPR functions that return a *recursive data type* (the list in this
- case). This is the solution we adopt. Rationale: the benefit of CPR on
- recursive data structures is slight, because it only affects the outer layer
- of a potentially massive data structure.
+ A. Don't give recursive data constructors or casts representing recursive newtype constructors
+ the CPR property (the list in this case). This is the solution we adopt.
+ Rationale: the benefit of CPR on recursive data structures is slight,
+ because it only affects the outer layer of a potentially massive data
+ structure.
B. Don't CPR any *recursive function*. That would be quite conservative, as it
would also affect e.g. the factorial function.
C. Flat CPR only for recursive functions. This prevents the asymptotic
@@ -1055,10 +1084,15 @@ What can we do about it?
`c` in the second eqn of `replicateC`). But we'd need to know which paths
were hot. We want such static branch frequency estimates in #20378.
-We adopt solution (A) It is ad-hoc, but appears to work reasonably well.
-Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:
-See Note [Detecting recursive data constructors]. We don't have to be perfect
-and can simply keep on unboxing if unsure.
+We adopt solution (A). It is ad-hoc, but appears to work reasonably well.
+Specifically:
+
+* For data constructors, in `cprTransformDataConWork` we check for a recursive
+ data constructor by calling `ae_rec_dc env`, which is just a memoised version
+ of `isRecDataCon`. See Note [Detecting recursive data constructors]
+* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype
+ by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.
+ See Note [CPR for recursive newtype constructors]
Note [Detecting recursive data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1075,12 +1109,15 @@ looks inside the following class of types, represented by `ty` (and responds
types of its data constructors and check `tc_args` for recursion.
C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to
`rhs`, look into the `rhs` type.
+ D. If `ty = f a`, then look into `f` and `a`
+ E. If `ty = ty' |> co`, then look into `ty'`
A few perhaps surprising points:
1. It deems any function type as non-recursive, because it's unlikely that
a recursion through a function type builds up a recursive data structure.
- 2. It doesn't look into kinds or coercion types because there's nothing to unbox.
+ 2. It doesn't look into kinds, literals or coercion types because we are
+ ultimately looking for value-level recursion.
Same for promoted data constructors.
3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;
we simply look at its definition/DataCons and its field tys and look for
@@ -1153,6 +1190,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon'
configurable like (4) to enable more re-use throughout the compiler, but haven't
found a killer app for that yet, so ultimately didn't do that.
+Note [CPR for recursive newtype constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A newtype constructor is considered recursive iff the data constructor of the
+equivalent datatype definition is recursive.
+See Note [CPR for recursive data constructors].
+Detection is a bit complicated by the fact that newtype constructor applications
+reflect as Casts in Core:
+
+ newtype List a = C (Maybe (a, List a))
+ xs = C (Just (0, C Nothing))
+ ==> {desugar to Core}
+ xs = Just (0, Nothing |> sym N:List) |> sym N:List
+
+So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than
+in `cprTransformDataConWork` as for data constructors.
+
Note [CPR examples]
~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -63,6 +63,7 @@ import Data.List ( unzip4 )
import GHC.Types.RepType
import GHC.Unit.Types
+import GHC.Core.TyCo.Rep
{-
************************************************************************
@@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc
| arg_ty <- map scaledThing (dataConRepArgTys dc) ]
go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
- go_arg_ty fuel visited_tcs ty
- --- | pprTrace "arg_ty" (ppr ty) False = undefined
+ go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $
+ case coreFullView ty of
+ TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args
+ -- See Note [Detecting recursive data constructors], points (B) and (C)
- | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty
- = go_arg_ty fuel visited_tcs ty'
+ ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'
-- See Note [Detecting recursive data constructors], point (A)
- | Just (tc, tc_args) <- splitTyConApp_maybe ty
- = go_tc_app fuel visited_tcs tc tc_args
+ CastTy ty' _ -> go_arg_ty fuel visited_tcs ty'
- | otherwise
- = NonRecursiveOrUnsure
+ AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a
+ -- See Note [Detecting recursive data constructors], point (D)
+
+ FunTy{} -> NonRecursiveOrUnsure
+ -- See Note [Detecting recursive data constructors], point (1)
+
+ -- (TyVarTy{} | LitTy{} | CastTy{})
+ _ -> NonRecursiveOrUnsure
go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
go_tc_app fuel visited_tcs tc tc_args =
case tyConDataCons_maybe tc of
- --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
+ ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined
_ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
-- This is the only place where we look at tc_args, which might have
-- See Note [Detecting recursive data constructors], point (C) and (5)
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -12,6 +12,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
+import GHC.Utils.Json
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger
@@ -46,9 +47,22 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage logger msg_opts opts message
- | log_diags_as_json = logJsonMsg logger messageClass message
+ | log_diags_as_json = do
+ decorated <- decorateDiagnostic logflags messageClass location doc
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) decorated
+
+ jsonMessage :: JsonDoc
+ jsonMessage = jsonDiagnostic rendered message
+
+ logJsonMsg logger messageClass jsonMessage
+
| otherwise = logMsg logger messageClass location doc
where
+ logflags :: LogFlags
+ logflags = logFlags logger
+
doc :: SDoc
doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -73,6 +73,9 @@ module GHC.Types.Error
, mkLocMessage
, mkLocMessageWarningGroups
, getCaretDiagnostic
+
+ , jsonDiagnostic
+
-- * Queries
, isIntrinsicErrorMessage
, isExtrinsicErrorMessage
@@ -109,7 +112,7 @@ import GHC.Utils.Panic
import GHC.Version (cProjectVersion)
import Data.Bifunctor
-import Data.Foldable ( fold, toList )
+import Data.Foldable
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
@@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where
pprDiagnostic (errMsgDiagnostic envelope)
]
-instance (Diagnostic e) => ToJson (Messages e) where
- json msgs = JSArray . toList $ json <$> getMessages msgs
-
{- Note [Discarding Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
@@ -586,15 +586,17 @@ https://json-schema.org
-}
schemaVersion :: String
-schemaVersion = "1.1"
+schemaVersion = "1.2"
+
-- See Note [Diagnostic Message JSON Schema] before editing!
-instance Diagnostic e => ToJson (MsgEnvelope e) where
- json m = JSObject $ [
+jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
+jsonDiagnostic rendered m = JSObject $ [
("version", JSString schemaVersion),
("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
("span", json $ errMsgSpan m),
("severity", json $ errMsgSeverity m),
("code", maybe JSNull json (diagnosticCode diag)),
+ ("rendered", JSString rendered),
("message", JSArray $ map renderToJSString diagMsg),
("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
++ [ ("reason", reasonJson)
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -62,6 +62,8 @@ module GHC.Utils.Logger
, logJsonMsg
, logDumpMsg
+ , decorateDiagnostic
+
-- * Dumping
, defaultDumpAction
, putDumpFile
@@ -419,26 +421,62 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
MCInfo -> printErrs msg
MCFatal -> printErrs msg
MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message
- MCDiagnostic _sev _rea _code -> printDiagnostics
+ MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
where
printOut = defaultLogActionHPrintDoc logflags False out
printErrs = defaultLogActionHPrintDoc logflags False err
putStrSDoc = defaultLogActionHPutStrDoc logflags False out
+
+-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
+-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
+-- message on `-fdiagnostics-as-json`.
+--
+-- We would want to eventually consolidate this. However, this is currently
+-- not feasible for the following reasons:
+--
+-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
+-- can not decorate the message in `printMessages`.
+--
+-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
+-- that reason we can not decorate the message in `defaultLogActionWithHandles`.
+--
+-- See also Note [JSON Error Messages]:
+--
+-- `jsonLogAction` should be removed along with -ddump-json
+--
+-- Also note that (1) is the reason why some parts of the compiler produce
+-- diagnostics that don't respect `-fdiagnostics-as-json`.
+--
+-- The plan as I see it is as follows:
+--
+-- 1. Refactor all places in the compiler that report diagnostics to go
+-- through `GHC.Driver.Errors.printMessages`.
+--
+-- (It's easy to find all those places by looking for who creates
+-- MCDiagnostic, either directly or via `mkMCDiagnostic` or
+-- `errorDiagnostic`.)
+--
+-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
+-- decoration at one place (either `printMessages` or
+-- `defaultLogActionWithHandles`)
+--
+-- This story is tracked by #24113.
+decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
+decorateDiagnostic logflags msg_class srcSpan msg = addCaret
+ where
-- Pretty print the warning flag, if any (#10752)
+ message :: SDoc
message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
- printDiagnostics = do
+ addCaret :: IO SDoc
+ addCaret = do
caretDiagnostic <-
if log_show_caret logflags
then getCaretDiagnostic msg_class srcSpan
else pure empty
- printErrs $ getPprStyle $ \style ->
+ return $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
(message $+$ caretDiagnostic $+$ blankLine)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
@@ -603,8 +641,8 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
-logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
-logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d)
+logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
+logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -147,6 +147,11 @@ Compiler
integer operations. Also, ``shuffleFloatX4#`` and ``shuffleDoubleX2#`` no longer
require ``-mavx``.
+- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
+ include the `rendered` diagnostics message, in the exact same format as what
+ GHC would have produced without -fdiagnostics-as-json (including ANSI escape
+ sequences).
+
GHCi
~~~~
=====================================
docs/users_guide/diagnostics-as-json-schema-1_2.json
=====================================
@@ -0,0 +1,144 @@
+{
+ "$schema": "https://json-schema.org/draft/2020-12/schema",
+ "title": "JSON Diagnostic Schema",
+ "description": "A Schema for specifying GHC diagnostics output as JSON",
+ "type": "object",
+ "properties": {
+ "version": {
+ "description": "The current JSON schema version this object conforms to",
+ "type": "string"
+ },
+ "ghcVersion": {
+ "description": "The GHC version",
+ "type": "string"
+ },
+ "span": {
+ "oneOf": [
+ { "$ref": "#/$defs/span" },
+ { "type": "null" }
+ ]
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "rendered": {
+ "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
+ "type": "string"
+ },
+ "message": {
+ "description": "The string output of the diagnostic message by GHC",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "hints": {
+ "description": "The suggested fixes",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "reason" : {
+ "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+ "oneOf": [
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by one or more GHC flags",
+ "properties": {
+ "flags": {
+ "type": "array",
+ "items": {
+ "description": "The name of a GHC flag controlling the diagnostic message",
+ "type": "string"
+ },
+ "minItems": 1
+ }
+ },
+ "required": ["flags"]
+ },
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+ "properties": {
+ "category": {
+ "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+ "type": "string"
+ }
+ },
+ "required": ["category"]
+ }
+ ]
+ }
+ },
+
+ "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.",
+ "required": [
+ "version",
+ "ghcVersion",
+ "span",
+ "severity",
+ "code",
+ "message",
+ "hints"
+ ],
+
+ "additionalProperties": false,
+ "$defs": {
+ "span": {
+ "description": "The span of the diagnostic",
+ "type": "object",
+ "properties": {
+ "file": {
+ "description": "The file in which the diagnostic occurs",
+ "type": "string"
+ },
+ "start": {
+ "description": "The start location of the diagnostic",
+ "$ref": "#/$defs/location"
+ },
+ "end": {
+ "description": "The end location of the diagnostic",
+ "$ref": "#/$defs/location"
+ }
+ },
+ "required": [
+ "file",
+ "start",
+ "end"
+ ],
+ "additionalProperties": false
+ },
+ "location": {
+ "description": "A location in a text file",
+ "type": "object",
+ "properties": {
+ "line": {
+ "description": "The line number",
+ "type": "integer"
+ },
+ "column": {
+ "description": "The column number",
+ "type": "integer"
+ }
+ },
+ "required": [
+ "line",
+ "column"
+ ],
+ "additionalProperties": false
+ }
+ }
+}
=====================================
docs/users_guide/using.rst
=====================================
@@ -1428,7 +1428,7 @@ messages and in GHCi:
a new line.
The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
- The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
+ The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`.
.. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
:shortdesc: Use colors in error messages
=====================================
rts/Interpreter.c
=====================================
@@ -473,6 +473,72 @@ void interp_shutdown( void ){
#endif
+const StgPtr ctoi_tuple_infos[] = {
+ (StgPtr) &stg_ctoi_t0_info,
+ (StgPtr) &stg_ctoi_t1_info,
+ (StgPtr) &stg_ctoi_t2_info,
+ (StgPtr) &stg_ctoi_t3_info,
+ (StgPtr) &stg_ctoi_t4_info,
+ (StgPtr) &stg_ctoi_t5_info,
+ (StgPtr) &stg_ctoi_t6_info,
+ (StgPtr) &stg_ctoi_t7_info,
+ (StgPtr) &stg_ctoi_t8_info,
+ (StgPtr) &stg_ctoi_t9_info,
+ (StgPtr) &stg_ctoi_t10_info,
+ (StgPtr) &stg_ctoi_t11_info,
+ (StgPtr) &stg_ctoi_t12_info,
+ (StgPtr) &stg_ctoi_t13_info,
+ (StgPtr) &stg_ctoi_t14_info,
+ (StgPtr) &stg_ctoi_t15_info,
+ (StgPtr) &stg_ctoi_t16_info,
+ (StgPtr) &stg_ctoi_t17_info,
+ (StgPtr) &stg_ctoi_t18_info,
+ (StgPtr) &stg_ctoi_t19_info,
+ (StgPtr) &stg_ctoi_t20_info,
+ (StgPtr) &stg_ctoi_t21_info,
+ (StgPtr) &stg_ctoi_t22_info,
+ (StgPtr) &stg_ctoi_t23_info,
+ (StgPtr) &stg_ctoi_t24_info,
+ (StgPtr) &stg_ctoi_t25_info,
+ (StgPtr) &stg_ctoi_t26_info,
+ (StgPtr) &stg_ctoi_t27_info,
+ (StgPtr) &stg_ctoi_t28_info,
+ (StgPtr) &stg_ctoi_t29_info,
+ (StgPtr) &stg_ctoi_t30_info,
+ (StgPtr) &stg_ctoi_t31_info,
+ (StgPtr) &stg_ctoi_t32_info,
+ (StgPtr) &stg_ctoi_t33_info,
+ (StgPtr) &stg_ctoi_t34_info,
+ (StgPtr) &stg_ctoi_t35_info,
+ (StgPtr) &stg_ctoi_t36_info,
+ (StgPtr) &stg_ctoi_t37_info,
+ (StgPtr) &stg_ctoi_t38_info,
+ (StgPtr) &stg_ctoi_t39_info,
+ (StgPtr) &stg_ctoi_t40_info,
+ (StgPtr) &stg_ctoi_t41_info,
+ (StgPtr) &stg_ctoi_t42_info,
+ (StgPtr) &stg_ctoi_t43_info,
+ (StgPtr) &stg_ctoi_t44_info,
+ (StgPtr) &stg_ctoi_t45_info,
+ (StgPtr) &stg_ctoi_t46_info,
+ (StgPtr) &stg_ctoi_t47_info,
+ (StgPtr) &stg_ctoi_t48_info,
+ (StgPtr) &stg_ctoi_t49_info,
+ (StgPtr) &stg_ctoi_t50_info,
+ (StgPtr) &stg_ctoi_t51_info,
+ (StgPtr) &stg_ctoi_t52_info,
+ (StgPtr) &stg_ctoi_t53_info,
+ (StgPtr) &stg_ctoi_t54_info,
+ (StgPtr) &stg_ctoi_t55_info,
+ (StgPtr) &stg_ctoi_t56_info,
+ (StgPtr) &stg_ctoi_t57_info,
+ (StgPtr) &stg_ctoi_t58_info,
+ (StgPtr) &stg_ctoi_t59_info,
+ (StgPtr) &stg_ctoi_t60_info,
+ (StgPtr) &stg_ctoi_t61_info,
+ (StgPtr) &stg_ctoi_t62_info,
+};
+
#if defined(PROFILING)
//
@@ -1828,82 +1894,11 @@ run_BCO:
SpW(-1) = BCO_PTR(o_tuple_bco);
SpW(-2) = tuple_info;
SpW(-3) = BCO_PTR(o_bco);
- W_ ctoi_t_offset;
int tuple_stack_words = (tuple_info >> 24) & 0xff;
- switch(tuple_stack_words) {
- case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break;
- case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break;
- case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break;
- case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break;
- case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break;
- case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break;
- case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break;
- case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break;
- case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break;
- case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break;
-
- case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
- case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
- case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
- case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
- case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
- case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
- case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
- case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
- case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
- case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
-
- case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
- case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
- case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
- case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
- case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
- case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
- case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
- case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
- case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
- case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
-
- case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
- case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
- case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
- case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
- case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
- case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
- case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
- case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
- case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
- case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
-
- case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
- case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
- case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
- case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
- case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
- case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
- case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
- case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
- case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
- case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
-
- case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
- case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
- case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
- case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
- case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
- case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
- case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
- case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
- case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
- case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
-
- case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
- case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
- case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
-
- default: barf("unsupported tuple size %d", tuple_stack_words);
+ if (tuple_stack_words > 62) {
+ barf("unsupported tuple size %d", tuple_stack_words);
}
-
+ W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
goto nextInsn;
=====================================
rts/PrimOps.cmm
=====================================
@@ -1211,16 +1211,27 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
gcptr trec, outer, arg;
trec = StgTSO_trec(CurrentTSO);
- outer = StgTRecHeader_enclosing_trec(trec);
- (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
- if (r != 0) {
- // Succeeded (either first branch or second branch)
- StgTSO_trec(CurrentTSO) = outer;
- return (ret);
- } else {
- // Did not commit: abort and restart.
- StgTSO_trec(CurrentTSO) = outer;
- jump stg_abort();
+ if (running_alt_code != 1) {
+ // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
+ // the nested transaction.
+ // See Note [catchRetry# implementation]
+ outer = StgTRecHeader_enclosing_trec(trec);
+ (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
+ if (r != 0) {
+ // Succeeded in first branch
+ StgTSO_trec(CurrentTSO) = outer;
+ return (ret);
+ } else {
+ // Did not commit: abort and restart.
+ StgTSO_trec(CurrentTSO) = outer;
+ jump stg_abort();
+ }
+ }
+ else {
+ // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
+ // using the parent transaction (not a nested one).
+ // See Note [catchRetry# implementation]
+ return (ret);
}
}
@@ -1453,21 +1464,26 @@ retry_pop_stack:
outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
- // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
- ASSERT(outer != NO_TREC);
- // Abort the transaction attempting the current branch
- ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
- ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+ // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
+
if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
- // Retry in the first branch: try the alternative
- ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
- StgTSO_trec(CurrentTSO) = trec;
+ // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
+ // transaction. See Note [catchRetry# implementation]
+
+ // check that we have a parent transaction
+ ASSERT(outer != NO_TREC);
+
+ // Abort the nested transaction
+ ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+ ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+
+ // As we are retrying in the lhs code, we must now try the rhs code
+ StgTSO_trec(CurrentTSO) = outer;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
jump stg_ap_v_fast [R1];
} else {
- // Retry in the alternative code: propagate the retry
- StgTSO_trec(CurrentTSO) = outer;
+ // Retry in the rhs code: propagate the retry
Sp = Sp + SIZEOF_StgCatchRetryFrame;
goto retry_pop_stack;
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1043,8 +1043,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
}
case CATCH_STM_FRAME:
- case CATCH_RETRY_FRAME:
- // CATCH frames within an atomically block: abort the
+ // CATCH_STM frame within an atomically block: abort the
// inner transaction and continue. Eventually we will
// hit the outer transaction that will get frozen (see
// above).
@@ -1056,14 +1055,40 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
{
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = trec -> enclosing_trec;
- debugTraceCap(DEBUG_stm, cap,
- "found atomically block delivering async exception");
+ debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
stmAbortTransaction(cap, trec);
stmFreeAbortedTRec(cap, trec);
tso -> trec = outer;
break;
};
+ case CATCH_RETRY_FRAME:
+ // CATCH_RETY frame within an atomically block: if we're executing
+ // the lhs code, abort the inner transaction and continue; if we're
+ // executing thr rhs, continue (no nested transaction to abort. See
+ // Note [catchRetry# implementation]). Eventually we will hit the
+ // outer transaction that will get frozen (see above).
+ //
+ // As for the CATCH_STM_FRAME case above, we do not care
+ // whether the transaction is valid or not because its
+ // possible validity cannot have caused the exception
+ // and will not be visible after the abort.
+ {
+ if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
+ debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
+ StgTRecHeader *trec = tso -> trec;
+ StgTRecHeader *outer = trec -> enclosing_trec;
+ stmAbortTransaction(cap, trec);
+ stmFreeAbortedTRec(cap, trec);
+ tso -> trec = outer;
+ }
+ else
+ {
+ debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
+ }
+ break;
+ };
+
default:
// see Note [Update async masking state on unwind] in Schedule.c
if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
=====================================
rts/STM.c
=====================================
@@ -1505,3 +1505,30 @@ void stmWriteTVar(Capability *cap,
}
/*......................................................................*/
+
+
+
+/*
+
+Note [catchRetry# implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+catchRetry# creates a nested transaction for its lhs:
+- if the lhs transaction succeeds:
+ - the lhs transaction is committed
+ - its read-variables are merged with those of the parent transaction
+ - the rhs code is ignored
+- if the lhs transaction retries:
+ - the lhs transaction is aborted
+ - its read-variables are merged with those of the parent transaction
+ - the rhs code is executed directly in the parent transaction (see #26028).
+
+So note that:
+- lhs code uses a nested transaction
+- rhs code doesn't use a nested transaction
+
+We have to take which case we're in into account (using the running_alt_code
+field of the catchRetry frame) in catchRetry's entry code, in retry#
+implementation, and also when an async exception is received (to cleanup the
+right number of transactions).
+
+*/
=====================================
testsuite/tests/cpranal/sigs/T25944.hs
=====================================
@@ -0,0 +1,114 @@
+{-# LANGUAGE UndecidableInstances, LambdaCase #-}
+
+-- | This file starts with a small reproducer for #25944 that is easy to debug
+-- and then continues with a much larger MWE that is faithful to the original
+-- issue.
+module T25944 (foo, bar, popMinOneT, popMinOne) where
+
+import Data.Functor.Identity ( Identity(..) )
+import Data.Coerce
+
+data ListCons a b = Nil | a :- !b
+newtype Fix f = Fix (f (Fix f)) -- Rec
+
+foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a)
+foo a b = go a
+ where
+ -- The outer loop arranges it so that the base case `go as` of `go2` is
+ -- bottom on the first iteration of the loop.
+ go (Fix Nil) = Fix Nil
+ go (Fix (a :- as)) = Fix (a :- go2 b)
+ where
+ go2 (Fix Nil) = go as
+ go2 (Fix (b :- bs)) = Fix (b :- go2 bs)
+
+bar :: Int -> (Fix (ListCons Int), Int)
+bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property
+
+-- Now the actual reproducer from #25944:
+
+newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) }
+
+cons :: Applicative m => a -> ListT m a -> ListT m a
+cons x xs = ListT (pure (x :- xs))
+
+nil :: Applicative m => ListT m a
+nil = ListT (pure Nil)
+
+instance Functor m => Functor (ListT m) where
+ fmap f (ListT m) = ListT (go <$> m)
+ where
+ go Nil = Nil
+ go (a :- m) = f a :- (f <$> m)
+
+foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b)
+ -> (a -> b -> c)
+ -> c
+ -> ListT m a -> b
+foldListT r c n = r h . runListT
+ where
+ h Nil = n
+ h (x :- ListT xs) = c x (r h xs)
+{-# INLINE foldListT #-}
+
+mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b
+mapListT =
+ foldListT
+ ((coerce ::
+ ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) ->
+ ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b))
+ (=<<))
+{-# INLINE mapListT #-}
+
+instance Monad m => Applicative (ListT m) where
+ pure x = cons x nil
+ {-# INLINE pure #-}
+ liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs
+ {-# INLINE liftA2 #-}
+
+instance Monad m => Monad (ListT m) where
+ xs >>= f = mapListT (flip (mapListT cons) . f) nil xs
+ {-# INLINE (>>=) #-}
+
+infixr 5 :<
+data Node w a b = Leaf a | !w :< b
+ deriving (Functor)
+
+bimapNode f g (Leaf x) = Leaf (f x)
+bimapNode f g (x :< xs) = x :< g xs
+
+newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) }
+
+-- | The 'Heap' type, specialised to the 'Identity' monad.
+type Heap w = HeapT w Identity
+
+instance Functor m => Functor (HeapT w m) where
+ fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT
+
+instance Monad m => Applicative (HeapT w m) where
+ pure = HeapT . pure . Leaf
+ (<*>) = liftA2 id
+
+instance Monad m => Monad (HeapT w m) where
+ HeapT m >>= f = HeapT (m >>= g)
+ where
+ g (Leaf x) = runHeapT (f x)
+ g (w :< xs) = pure (w :< (xs >>= f))
+
+popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a))
+popMinOneT = go mempty [] . runHeapT
+ where
+ go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a))
+ go' a Nothing = pure Nothing
+ go' a (Just (w, HeapT xs)) = go (a <> w) [] xs
+
+ go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a))
+ go w a (ListT xs) = xs >>= \case
+ Nil -> go' w (undefined)
+ Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a)))
+ (u :< x) :- xs -> go w ((u,x) : a) xs
+{-# INLINE popMinOneT #-}
+
+popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a)
+popMinOne = runIdentity . popMinOneT
+{-# INLINE popMinOne #-}
=====================================
testsuite/tests/cpranal/sigs/T25944.stderr
=====================================
@@ -0,0 +1,17 @@
+
+==================== Cpr signatures ====================
+T25944.$fApplicativeHeapT:
+T25944.$fApplicativeListT:
+T25944.$fFunctorHeapT:
+T25944.$fFunctorListT:
+T25944.$fFunctorNode:
+T25944.$fMonadHeapT:
+T25944.$fMonadListT:
+T25944.bar: 1
+T25944.foo:
+T25944.popMinOne: 2(1(1,))
+T25944.popMinOneT:
+T25944.runHeapT:
+T25944.runListT:
+
+
=====================================
testsuite/tests/cpranal/sigs/all.T
=====================================
@@ -12,3 +12,4 @@ test('T16040', normal, compile, [''])
test('T19232', normal, compile, [''])
test('T19398', normal, compile, [''])
test('T19822', normal, compile, [''])
+test('T25944', normal, compile, [''])
=====================================
testsuite/tests/driver/json.stderr
=====================================
@@ -1 +1 @@
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
=====================================
testsuite/tests/driver/json_warn.stderr
=====================================
@@ -1,2 +1,2 @@
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\n (imported from Prelude, but defined in GHC.Internal.List):\n \"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\"\n","message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
=====================================
testsuite/tests/lib/stm/T26028.hs
=====================================
@@ -0,0 +1,23 @@
+module Main where
+
+import GHC.Conc
+
+forever :: IO String
+forever = delay 10 >> forever
+
+terminates :: IO String
+terminates = delay 1 >> pure "terminates"
+
+delay s = threadDelay (1000000 * s)
+
+async :: IO a -> IO (STM a)
+async a = do
+ var <- atomically (newTVar Nothing)
+ forkIO (a >>= atomically . writeTVar var . Just)
+ pure (readTVar var >>= maybe retry pure)
+
+main :: IO ()
+main = do
+ x <- mapM async $ terminates : replicate 50000 forever
+ r <- atomically (foldr1 orElse x)
+ print r
=====================================
testsuite/tests/lib/stm/T26028.stdout
=====================================
@@ -0,0 +1 @@
+"terminates"
=====================================
testsuite/tests/lib/stm/all.T
=====================================
@@ -0,0 +1 @@
+test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f348d6432381eeb1cf782275ffb85b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f348d6432381eeb1cf782275ffb85b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
24 Jul '25
Simon Hengel pushed new branch wip/sol/driver-diagnostics at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sol/driver-diagnostics
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T18570] 2 commits: Calculate multiplicity for record selector functions
by Sjoerd Visscher (＠trac-sjoerd_visscher) 24 Jul '25
by Sjoerd Visscher (＠trac-sjoerd_visscher) 24 Jul '25
24 Jul '25
Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC
Commits:
a1a4b6f0 by Sjoerd Visscher at 2025-07-24T15:15:23+02:00
Calculate multiplicity for record selector functions
Until now record selector functions always had multiplicity Many, but when all the other fields have been declared with multiplicity Many (including the case when there are no other fields), then the selector function is allowed to be used linearly too, as it is allowed to discard all the other fields. Since in that case the multiplicity can be both One and Many, the selector function is made multiplicity-polymorphic.
See Note [Multiplicity and partial selectors]
Fixes !13689
- - - - -
57b9810e by Sjoerd Visscher at 2025-07-24T15:15:24+02:00
Fix field type mismatch error handling
Errors in check_fields don't fail in the monad. (This commit also makes this more clear in the code.) So they didn't trigger the recovery code in checkValidTyCl.
Fixes issue #26149
- - - - -
22 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/bugs.rst
- docs/users_guide/exts/linear_types.rst
- + testsuite/tests/linear/should_compile/LinearRecordSelector.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs
- + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr
- testsuite/tests/linear/should_fail/all.T
- testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr
- testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
- testsuite/tests/perf/compiler/T16875.stderr
- testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
- testsuite/tests/typecheck/should_fail/CommonFieldTypeMismatch.stderr
- testsuite/tests/typecheck/should_fail/T12083a.hs
- testsuite/tests/typecheck/should_fail/T12083a.stderr
- testsuite/tests/typecheck/should_fail/T9739.hs
- testsuite/tests/typecheck/should_fail/T9739.stderr
- utils/haddock/html-test/ref/Bug294.html
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -44,6 +44,7 @@ module GHC.Core.DataCon (
dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,
dataConInstUnivs,
dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
+ dataConOtherFieldsAllMultMany,
dataConSrcBangs,
dataConSourceArity, dataConVisArity, dataConRepArity,
dataConIsInfix,
@@ -1406,6 +1407,15 @@ dataConFieldType_maybe :: DataCon -> FieldLabelString
dataConFieldType_maybe con label
= find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
+-- | Check if all the fields of the 'DataCon' have multiplicity 'Many',
+-- except for the given labelled field. In this case the selector
+-- of the given field can be a linear function, since it is allowed
+-- to discard all the other fields.
+dataConOtherFieldsAllMultMany :: DataCon -> FieldLabelString -> Bool
+dataConOtherFieldsAllMultMany con label
+ = all (\(fld, mult) -> flLabel fld == label || isManyTy mult)
+ (dcFields con `zip` (scaledMult <$> dcOrigArgTys con))
+
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
-- The list is in one-to-one correspondence with the arity of the 'DataCon'
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -3541,12 +3541,12 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit _ (RawHoleFit sd) = sd
pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) =
hang display 2 provenance
- where tyApp = sep $ zipWithEqual pprArg vars hfWrap
+ where tyApps = concat $ zipWithEqual pprArg vars hfWrap
where pprArg b arg = case binderFlag b of
- Specified -> text "@" <> pprParendType arg
+ Specified -> [text "@" <> pprParendType arg]
-- Do not print type application for inferred
-- variables (#16456)
- Inferred -> empty
+ Inferred -> []
Required -> pprPanic "pprHoleFit: bad Required"
(ppr b <+> ppr arg)
tyAppVars = sep $ punctuate comma $
@@ -3573,9 +3573,9 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) =
IdHFCand id_ -> pprPrefixOcc id_
tyDisp = ppWhen sTy $ dcolon <+> ppr hfType
has = not . null
- wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))
+ wrapDisp = ppWhen (has tyApps && (sWrp || sWrpVars))
$ text "with" <+> if sWrp || not sTy
- then occDisp <+> tyApp
+ then occDisp <+> sep tyApps
else tyAppVars
docs = case hfDoc of
Just d -> pprHsDocStrings d
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -4787,6 +4787,7 @@ checkValidTyCl tc
= setSrcSpan (getSrcSpan tc) $
addTyConCtxt tc $
recoverM recovery_code $
+ checkNoErrs $
do { traceTc "Starting validity for tycon" (ppr tc)
; checkValidTyCon tc
; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking]
@@ -4818,6 +4819,9 @@ See indexed-types/should_fail/BadSock and #10896
Some notes:
+* Not all errors in `checkValidTyCon` fail in the monad. To make sure
+ we also recover from these, we use `checkNoErrs`. See (#26149)
+
* We must make fakes for promoted DataCons too. Consider (#15215)
data T a = MkT ...
data S a = ...T...MkT....
@@ -4991,7 +4995,7 @@ checkValidTyCon tc
check_fields ((label, con1) :| other_fields)
-- These fields all have the same name, but are from
-- different constructors in the data type
- = recoverM (return ()) $ mapM_ checkOne other_fields
+ = mapM_ checkOne other_fields
-- Check that all the fields in the group have the same type
-- NB: this check assumes that all the constructors of a given
-- data type use the same type variables
@@ -5001,11 +5005,14 @@ checkValidTyCon tc
lbl = flLabel label
checkOne (_, con2) -- Do it both ways to ensure they are structurally identical
- = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
- ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
+ = case (one_vs_two `firstJust` two_vs_one) of
+ Just err -> addErrTc err
+ Nothing -> return ()
where
res2 = dataConOrigResTy con2
fty2 = dataConFieldType con2 lbl
+ one_vs_two = checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
+ two_vs_one = checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1
checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
-- Checks the partial record field selector, and warns.
@@ -5027,13 +5034,15 @@ checkPartialRecordField all_cons fld
inst_tys = dataConResRepTyArgs con1
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
- -> Type -> Type -> Type -> Type -> TcM ()
+ -> Type -> Type -> Type -> Type -> Maybe TcRnMessage
checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
- = do { checkTc (isJust mb_subst1) (TcRnCommonFieldResultTypeMismatch con1 con2 fld)
- ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) }
- where
- mb_subst1 = tcMatchTy res1 res2
- mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2
+ | Just subst_res <- tcMatchTy res1 res2 -- Result types match
+ = if isJust (tcMatchTyX subst_res fty1 fty2) -- Match field types under `subst_res`
+ then Nothing -- Success!
+ else -- Field types don't match
+ Just $ TcRnCommonFieldTypeMismatch con1 con2 fld
+ | otherwise -- Result types don't match
+ = Just $ TcRnCommonFieldResultTypeMismatch con1 con2 fld
-------------------------------
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
import GHC.Tc.Utils.TcType
-import GHC.Builtin.Types( unitTy )
+import GHC.Builtin.Types( unitTy, manyDataConTy, multiplicityTy )
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Hs
@@ -71,6 +71,7 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Reader ( mkRdrUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Var (mkTyVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
@@ -853,11 +854,11 @@ mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
mkRecSelBinds tycons
- = map mkRecSelBind [ (tc,fld) | tc <- tycons
- , fld <- tyConFieldLabels tc ]
+ = [ mkRecSelBind tc fld | tc <- tycons
+ , fld <- tyConFieldLabels tc ]
-mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
-mkRecSelBind (tycon, fl)
+mkRecSelBind :: TyCon -> FieldLabel -> (Id, LHsBind GhcRn)
+mkRecSelBind tycon fl
= mkOneRecordSelector all_cons (RecSelData tycon) fl
FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors]
where
@@ -916,17 +917,24 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- thus suppressing making a binding
-- A slight hack!
+ all_other_fields_unrestricted = all all_other_unrestricted all_cons
+ where
+ all_other_unrestricted PatSynCon{} = False
+ all_other_unrestricted (RealDataCon dc) = dataConOtherFieldsAllMultMany dc lbl
+
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
- | otherwise = mkForAllTys sel_tvbs $
+ | otherwise = mkForAllTys (sel_tvbs ++ mult_tvb) $
-- Urgh! See Note [The stupid context] in GHC.Core.DataCon
- mkPhiTy (conLikeStupidTheta con1) $
+ mkPhiTy (conLikeStupidTheta con1) $
-- req_theta is empty for normal DataCon
- mkPhiTy req_theta $
- mkVisFunTyMany data_ty $
- -- Record selectors are always typed with Many. We
- -- could improve on it in the case where all the
- -- fields in all the constructor have multiplicity Many.
+ mkPhiTy req_theta $
+ mkVisFunTy sel_mult data_ty $
field_ty
+ non_partial = length all_cons == length cons_w_field -- See Note [Multiplicity and partial selectors]
+ (mult_tvb, sel_mult) = if non_partial && all_other_fields_unrestricted
+ then ([mkForAllTyBinder (Invisible InferredSpec) mult_var], mkTyVarTy mult_var)
+ else ([], manyDataConTy)
+ mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
@@ -1165,4 +1173,13 @@ Therefore, when used in the right-hand side of `unT`, GHC attempts to
instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative.
To make sure that GHC is OK with this, we enable ImpredicativeTypes internally
when typechecking these HsBinds so that the user does not have to.
+
+Note [Multiplicity and partial selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While all logic for making record selectors multiplicity-polymorphic also applies
+to partial selectors, there is a technical difficulty: the catch-all default case
+that is added throws away its argument, and so cannot be linear. A simple workaround
+was not found. There may exist a more complicated workaround, but the combination of
+linear types and partial selectors is not expected to be very popular in practice, so
+it was decided to not allow multiplicity-polymorphic partial selectors at all.
-}
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -67,6 +67,13 @@ Language
This causes the constructor to have type ``Rec :: Int %'Many -> Char %1 -> Record``.
+ Also record selector functions are now multiplicity-polymorphic when possible.
+ In the above example the selector function ``y`` now has type
+ ``y :: Record %m -> Char``, because the ``x`` field is allowed to be discarded.
+ In particular this always applies to the selector of a newtype wrapper.
+ (Note that in theory this should also work with partial record selectors,
+ but for technical reasons this is not supported.)
+
* The :extension:`ExplicitNamespaces` extension now allows the ``data``
namespace specifier in import and export lists.
=====================================
docs/users_guide/bugs.rst
=====================================
@@ -701,6 +701,9 @@ Bugs in GHC
- Because of a toolchain limitation we are unable to support full Unicode paths
on Windows. On Windows we support up to Latin-1. See :ghc-ticket:`12971` for more.
+- For technical reasons, partial record selectors cannot be made
+ multiplicity-polymorphic, so they are always unrestricted.
+
.. _bugs-ghci:
Bugs in GHCi (the interactive GHC)
=====================================
docs/users_guide/exts/linear_types.rst
=====================================
@@ -238,7 +238,7 @@ to use ``MkT1`` in higher order functions. The additional multiplicity
argument ``m`` is marked as inferred (see
:ref:`inferred-vs-specified`), so that there is no conflict with
visible type application. When displaying types, unless
-``-XLinearTypes`` is enabled, multiplicity polymorphic functions are
+``-XLinearTypes`` is enabled, multiplicity-polymorphic functions are
printed as regular functions (see :ref:`printing-linear-types`);
therefore constructors appear to have regular function types.
@@ -256,21 +256,33 @@ using GADT syntax or record syntax. Given
::
data T2 a b c where
- MkT2 :: a -> b %1 -> c %1 -> T2 a b c -- Note unrestricted arrow in the first argument
+ MkT2 :: a -> b %1 -> c -> T2 a b c -- Note the unrestricted arrows on a and c
-the value ``MkT2 x y z`` can be constructed only if ``x`` is
-unrestricted. On the other hand, a linear function which is matching
-on ``MkT2 x y z`` must consume ``y`` and ``z`` exactly once, but there
-is no restriction on ``x``. The same example can be written using record syntax:
+the value ``MkT2 x y z`` can be constructed only if ``x`` and
+``z`` are unrestricted. On the other hand, a linear function which is
+matching on ``MkT2 x y z`` must consume ``y`` exactly once, but there
+is no restriction on ``x`` and ``z``.
+The same example can be written using record syntax:
::
- data T2 a b c = MkT2 { x %'Many :: a, y :: b, z :: c }
+ data T2 a b c = MkT2 { x %'Many :: a, y :: b, z %'Many :: c }
Again, the constructor ``MkT2`` has type ``MkT2 :: a -> b %1 -> c %1 -> T2 a b c``.
Note that by default record fields are linear, only unrestricted fields
-require a multiplicity annotation. The annotation has no effect on the record selectors.
-So ``x`` has type ``x :: T2 a b c -> a`` and similarly ``y`` has type ``y :: T2 a b c -> b``.
+require a multiplicity annotation.
+
+The multiplicity of record selectors is inferred from the multiplicity of the fields. Note that
+the effect of a selector is to discard all the other fields, so it can only be linear if all the
+other fields are unrestricted. So ``x`` has type ``x :: T2 a b c -> a``, because the ``y`` field
+is not unrestricted. But the ``x`` and ``z`` fields are unrestricted, so the selector for ``y``
+can be linear, and therefore it is made to be multiplicity-polymorphic: ``y :: T2 a b c %m -> b``.
+In particular this always applies to the selector of a newtype wrapper.
+
+In the case of multiple constructors, this logic is repeated for each constructor. So a selector
+is only made multiplicity-polymorphic if for every constructor all the other fields are unrestricted.
+(For technical reasons, partial record selectors cannot be made multiplicity-polymorphic, so they
+are always unrestricted.)
It is also possible to define a multiplicity-polymorphic field:
=====================================
testsuite/tests/linear/should_compile/LinearRecordSelector.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
+module LinearRecordSelector where
+
+import GHC.Exts (Multiplicity(..))
+import Prelude
+
+data Test = A { test :: Int, test2 %Many :: String } | B { test %Many :: Int, test3 %Many :: Char }
+
+test1 :: Test %1 -> Int
+test1 a = test a
+
+testM :: Test -> Int
+testM a = test a
+
+testX :: Test %m -> Int
+testX = test
+
+newtype NT = NT { unNT :: Int }
+
+nt :: NT %m -> Int
+nt a = unNT a
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -36,6 +36,7 @@ test('LinearTH3', normal, compile, [''])
test('LinearTH4', req_th, compile, [''])
test('LinearHole', normal, compile, [''])
test('LinearDataConSections', normal, compile, [''])
+test('LinearRecordSelector', normal, compile, ['-dcore-lint'])
test('T18731', normal, compile, [''])
test('T19400', unless(compiler_debugged(), skip), compile, [''])
test('T20023', normal, compile, [''])
=====================================
testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
+module LinearRecordSelector where
+
+import GHC.Exts (Multiplicity(..))
+import Prelude
+
+data Test1 = A1 { testA11 :: Int, testA12 :: String }
+
+-- Fails because testA12 is linear
+test1 :: Test1 %1 -> Int
+test1 a = testA11 a
+
+data Test2 = A2 { testA2 :: Int } | B2 { testB2 %Many :: Char }
+
+-- Fails because testA2 is partial
+test2 :: Test2 %1 -> Int
+test2 a = testA2 a
=====================================
testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr
=====================================
@@ -0,0 +1,10 @@
+LinearRecordSelectorFail.hs:11:7: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘a’
+ • In an equation for ‘test1’: test1 a = testA11 a
+
+LinearRecordSelectorFail.hs:17:7: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘a’
+ • In an equation for ‘test2’: test2 a = testA2 a
+
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -11,6 +11,7 @@ test('LinearNoExt', normal, compile_fail, [''])
test('LinearNoExtU', normal, compile_fail, [''])
test('LinearAsPat', normal, compile_fail, [''])
test('LinearLazyPat', normal, compile_fail, [''])
+test('LinearRecordSelectorFail', normal, compile_fail, [''])
test('LinearRecordUpdate', normal, compile_fail, [''])
test('LinearSeq', normal, compile_fail, [''])
test('LinearViewPattern', normal, compile_fail, [''])
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr
=====================================
@@ -1,4 +1,3 @@
-
DRFHoleFits.hs:7:7: error: [GHC-88464]
• Found hole: _ :: T -> Int
• In the expression: _ :: T -> Int
@@ -6,8 +5,8 @@ DRFHoleFits.hs:7:7: error: [GHC-88464]
• Relevant bindings include
bar :: T -> Int (bound at DRFHoleFits.hs:7:1)
Valid hole fits include
- foo :: T -> Int (defined at DRFHoleFits.hs:5:16)
bar :: T -> Int (defined at DRFHoleFits.hs:7:1)
+ foo :: T -> Int (defined at DRFHoleFits.hs:5:16)
DRFHoleFits.hs:8:7: error: [GHC-88464]
• Found hole: _ :: A.S -> Int
@@ -20,3 +19,4 @@ DRFHoleFits.hs:8:7: error: [GHC-88464]
A.foo :: A.S -> Int
(imported qualified from ‘DRFHoleFits_A’ at DRFHoleFits.hs:3:1-35
(and originally defined at DRFHoleFits_A.hs:5:16-18))
+
=====================================
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
=====================================
@@ -1,5 +1,8 @@
data Main.R = Main.MkR {Main.foo :: GHC.Internal.Types.Int}
-Main.foo :: Main.R -> GHC.Internal.Types.Int
-Main.foo :: Main.R -> GHC.Internal.Types.Int
-Main.foo :: Main.R -> GHC.Internal.Types.Int
+Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} .
+ Main.R %m_0 -> GHC.Internal.Types.Int
+Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} .
+ Main.R %m_0 -> GHC.Internal.Types.Int
+Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} .
+ Main.R %m_0 -> GHC.Internal.Types.Int
42
=====================================
testsuite/tests/perf/compiler/T16875.stderr
=====================================
@@ -6,7 +6,5 @@ T16875.hs:12:5: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
• In an equation for ‘a’: a = _
• Relevant bindings include a :: p (bound at T16875.hs:12:1)
Valid hole fits include
- a :: forall {p}. p
- with a
- (defined at T16875.hs:12:1)
+ a :: forall {p}. p (defined at T16875.hs:12:1)
=====================================
testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
=====================================
@@ -1,22 +1,32 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 82, types: 52, coercions: 29, joins: 0/0}
+ = {terms: 83, types: 55, coercions: 31, joins: 0/0}
--- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0}
-unsafeToInteger1 :: forall (n :: Nat). Signed n -> Signed n
+-- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
+unsafeToInteger1
+ :: forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity).
+ Signed n %m -> Signed n
[GblId, Arity=1, Unf=OtherCon []]
-unsafeToInteger1 = \ (@(n :: Nat)) (ds :: Signed n) -> ds
+unsafeToInteger1
+ = \ (@(n :: Nat))
+ (@(m :: GHC.Internal.Types.Multiplicity))
+ (ds :: Signed n) ->
+ ds
--- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0}
-unsafeToInteger :: forall (n :: Nat). Signed n -> Integer
+-- RHS size: {terms: 1, types: 0, coercions: 10, joins: 0/0}
+unsafeToInteger
+ :: forall (n :: Nat) {m :: GHC.Internal.Types.Multiplicity}.
+ Signed n %m -> Integer
[GblId[[RecSel]], Arity=1, Unf=OtherCon []]
unsafeToInteger
= unsafeToInteger1
- `cast` (forall (n :: <Nat>_N).
- <Signed n>_R %<Many>_N ->_R OpaqueNoCastWW.N:Signed <n>_P
- :: (forall (n :: Nat). Signed n -> Signed n)
- ~R# (forall (n :: Nat). Signed n -> Integer))
+ `cast` (forall (n :: <Nat>_N) (m :: <GHC.Internal.Types.Multiplicity>_N).
+ <Signed n>_R %<m>_N ->_R OpaqueNoCastWW.N:Signed <n>_P
+ :: (forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity).
+ Signed n %m -> Signed n)
+ ~R# (forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity).
+ Signed n %m -> Integer))
-- RHS size: {terms: 8, types: 7, coercions: 21, joins: 0/0}
times [InlPrag=OPAQUE]
=====================================
testsuite/tests/typecheck/should_fail/CommonFieldTypeMismatch.stderr
=====================================
@@ -1,3 +1,4 @@
-CommonFieldTypeMismatch.hs:3:1: [GHC-91827]
- Constructors A1 and A2 give different types for field ‘fld’
- In the data type declaration for ‘A’
+CommonFieldTypeMismatch.hs:3:1: error: [GHC-91827]
+ • Constructors A1 and A2 give different types for field ‘fld’
+ • In the data type declaration for ‘A’
+
=====================================
testsuite/tests/typecheck/should_fail/T12083a.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
module T12803a where
type Constrd a = Num a ⇒ a
=====================================
testsuite/tests/typecheck/should_fail/T12083a.stderr
=====================================
@@ -1,14 +1,14 @@
-
-T12083a.hs:6:1: error: [GHC-91510]
+T12083a.hs:7:1: error: [GHC-91510]
• Illegal qualified type: Num a => a
• In the type synonym declaration for ‘Constrd’
Suggested fix:
Perhaps you intended to use the ‘RankNTypes’ extension (implied by ‘ImpredicativeTypes’)
-T12083a.hs:10:26: error: [GHC-25709]
+T12083a.hs:11:26: error: [GHC-25709]
• Data constructor ‘ExistentiallyLost’ has existential type variables, a context, or a specialised result type
ExistentiallyLost :: forall u. TC u => u -> ExistentiallyLost
• In the definition of data constructor ‘ExistentiallyLost’
In the data type declaration for ‘ExistentiallyLost’
Suggested fix:
Enable any of the following extensions: ‘ExistentialQuantification’ or ‘GADTs’
+
=====================================
testsuite/tests/typecheck/should_fail/T9739.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
module T9739 where
class Class3 a => Class1 a where
=====================================
testsuite/tests/typecheck/should_fail/T9739.stderr
=====================================
@@ -1,5 +1,4 @@
-
-T9739.hs:4:1: error: [GHC-29210]
+T9739.hs:5:1: error: [GHC-29210]
• Superclass cycle for ‘Class1’
one of whose superclasses is ‘Class3’
one of whose superclasses is ‘Class1’
@@ -7,10 +6,11 @@ T9739.hs:4:1: error: [GHC-29210]
Suggested fix:
Perhaps you intended to use the ‘UndecidableSuperClasses’ extension
-T9739.hs:9:1: error: [GHC-29210]
+T9739.hs:10:1: error: [GHC-29210]
• Superclass cycle for ‘Class3’
one of whose superclasses is ‘Class1’
one of whose superclasses is ‘Class3’
• In the class declaration for ‘Class3’
Suggested fix:
Perhaps you intended to use the ‘UndecidableSuperClasses’ extension
+
=====================================
utils/haddock/html-test/ref/Bug294.html
=====================================
@@ -159,9 +159,13 @@
><p class="src"
><a id="v:problemField" class="def"
>problemField</a
- > :: TO <a href="#" title="Bug294"
+ > :: <span class="keyword"
+ >forall</span
+ > {m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >}. TO <a href="#" title="Bug294"
>A</a
- > -> <a href="#" title="Bug294"
+ > %m -> <a href="#" title="Bug294"
>A</a
> <a href="#" class="selflink"
>#</a
@@ -171,9 +175,13 @@
><p class="src"
><a id="v:problemField-39-" class="def"
>problemField'</a
- > :: DO <a href="#" title="Bug294"
+ > :: <span class="keyword"
+ >forall</span
+ > {m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >}. DO <a href="#" title="Bug294"
>A</a
- > -> <a href="#" title="Bug294"
+ > %m -> <a href="#" title="Bug294"
>A</a
> <a href="#" class="selflink"
>#</a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c037b309dbcd62c9fb39530b67151…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c037b309dbcd62c9fb39530b67151…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.10.3-backports] 11 commits: 9.10 hadrian can build with Cabal-3.12.1
by Zubin (＠wz1000) 24 Jul '25
by Zubin (＠wz1000) 24 Jul '25
24 Jul '25
Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC
Commits:
351792e7 by Jens Petersen at 2025-07-24T14:30:14+05:30
9.10 hadrian can build with Cabal-3.12.1
fixes #25605
(cherry picked from commit 07f17b6ed1bb0ba7134ee8dfd992036e97552c94)
- - - - -
bfcdc1b9 by sheaf at 2025-07-24T14:30:14+05:30
Don't cache solved [W] HasCallStack constraints
This commit ensures we do not add solved Wanted constraints that mention
HasCallStack or HasExceptionContext constraints to the set of solved
Wanted dictionary constraints: caching them is invalid, because re-using
such cached dictionaries means using an old call-stack instead of
constructing a new one, as was reported in #25529.
Fixes #25529.
(cherry picked from commit 256ac29c8df4f17a1d50ea243408d506ebf395d6)
- - - - -
967b4bb0 by Zubin Duggal at 2025-07-24T14:30:14+05:30
In commit "Don't cache solved [W] HasCallStack constraints" (256ac29c8df4f17a1d50ea243408d506ebf395d6),
we attempt to use `tryM` to avoid errors when looking up certain known-key names like CallStack while
compiling ghc-prim and ghc-internal.
Unfortunately, `tryM` doesn't catch module lookup errors. This manifests as a failure to build ghc-prim
in `--make` mode on the GHC 9.10 branch.
Instead, we explicitly avoid doing lookups when we are compiling ghc-prim or ghc-internal instead of
relying on catching the exception.
- - - - -
16c06609 by Zubin Duggal at 2025-07-24T14:30:14+05:30
Consider `PromotedDataCon` in `tyConStupidTheta`
Haddock checks data declarations for the stupid theta so as not to
pretty-print them as empty contexts. Type data declarations end up as
`PromotedDataCon`s by the time Haddock performs this check, causing a
panic. This commit extends `tyConStupidTheta` so that it returns an
empty list for `PromotedDataCon`s. This decision was guided by the fact
that type data declarations never have data type contexts (see (R1) in
Note [Type data declarations]).
Fixes #25739.
(cherry picked from commit 8d33d048dbe159a045a4c304fa92318365a3dfe2)
- - - - -
a5554b70 by Ryan Hendrickson at 2025-07-24T14:30:14+05:30
haddock: Preserve indentation in multiline examples
Intended for use with :{ :}, but doesn't look for those characters. Any
consecutive lines with birdtracks will only have initial whitespace
stripped up to the column of the first line.
(cherry picked from commit 2c73250494fd9f48ebda6d6fe72f0cd03182aff1)
- - - - -
d7d877e0 by Ryan Hendrickson at 2025-07-24T14:30:14+05:30
haddock: Parse math even after ordinary characters
Fixes a bug where math sections were not recognized if preceded by a
character that isn't special (like space or a markup character).
(cherry picked from commit b790d647c1ccdcc9aa8f166c3e0e42d0a5c29625)
- - - - -
1b0b7cfa by Ryan Hendrickson at 2025-07-24T14:30:15+05:30
haddock: Fix links to type operators
(cherry picked from commit a0adc30d892f14f543f39d5c45faccacbc28afb4)
- - - - -
d275faa0 by Ryan Hendrickson at 2025-07-24T14:30:15+05:30
haddock: Document instances from other packages
When attaching instances to `Interface`s, it isn't enough just to look
for instances in the list of `Interface`s being processed. We also need
to look in the modules on which they depend, including those outside of
this package.
Fixes #25147.
Fixes #26079.
(cherry picked from commit a26243fde4680271712a3d774e17f6cd6da4a652)
- - - - -
b6cd6cff by Zubin Duggal at 2025-07-24T14:30:15+05:30
haddock: Don't warn about missing link destinations for derived names.
Fixes #26114
(cherry picked from commit 5dabc718a04bfc4d277c5ff7f815ee3d6b9670cb)
- - - - -
83e7988d by Zubin Duggal at 2025-07-24T14:30:15+05:30
Bump haddock version to 2.31.3
- - - - -
5b6f36b2 by Zubin Duggal at 2025-07-24T14:30:15+05:30
Prepare 9.10.3 prerelease
- - - - -
26 changed files:
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Types.hs
- configure.ac
- + docs/users_guide/9.10.3-notes.rst
- hadrian/hadrian.cabal
- hadrian/src/Context.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Hadrian/Haskell/Cabal/Type.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/CabalReinstall.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Rules/Rts.hs
- hadrian/src/Settings/Builders/Ghc.hs
- testsuite/driver/testlib.py
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/driver/T20604/T20604.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/static-plugins.stdout
- + testsuite/tests/typecheck/should_run/T25529.hs
- + testsuite/tests/typecheck/should_run/T25529.stdout
- testsuite/tests/typecheck/should_run/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Core.Predicate (
-- Implicit parameters
isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
- isExceptionContextPred,
+ isExceptionContextPred, isExceptionContextTy,
isIPPred_maybe,
-- Evidence variables
@@ -39,7 +39,6 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
-import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
@@ -292,7 +291,7 @@ isExceptionContextPred cls tys
| otherwise
= Nothing
--- | Is a type a 'CallStack'?
+-- | Is a type an 'ExceptionContext'?
isExceptionContextTy :: Type -> Bool
isExceptionContextTy ty
| Just tc <- tyConAppTyCon_maybe ty
@@ -338,31 +337,38 @@ isCallStackTy ty
isIPLikePred :: Type -> Bool
-- Is `pred`, or any of its superclasses, an implicit parameter?
-- See Note [Local implicit parameters]
-isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred
-
-mentionsIP :: Type -> Class -> [Type] -> Bool
--- Is (cls tys) an implicit parameter with key `str_ty`, or
--- is any of its superclasses such at thing.
+isIPLikePred pred =
+ mentions_ip_pred initIPRecTc (const True) (const True) pred
+
+mentionsIP :: (Type -> Bool) -- ^ predicate on the string
+ -> (Type -> Bool) -- ^ predicate on the type
+ -> Class
+ -> [Type] -> Bool
+-- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
+--
+-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
+-- are both @True@,
+-- - or any superclass of @cls tys@ has this property.
+--
-- See Note [Local implicit parameters]
-mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys
-
-mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool
-mentions_ip rec_clss mb_str_ty cls tys
- | Just (str_ty', _) <- isIPPred_maybe cls tys
- = case mb_str_ty of
- Nothing -> True
- Just str_ty -> str_ty `eqType` str_ty'
+mentionsIP = mentions_ip initIPRecTc
+
+mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
+mentions_ip rec_clss str_cond ty_cond cls tys
+ | Just (str_ty, ty) <- isIPPred_maybe cls tys
+ = str_cond str_ty && ty_cond ty
| otherwise
- = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)
+ = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
| sc_sel_id <- classSCSelIds cls ]
-mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool
-mentions_ip_pred rec_clss mb_str_ty ty
+
+mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
+mentions_ip_pred rec_clss str_cond ty_cond ty
| Just (cls, tys) <- getClassPredTys_maybe ty
, let tc = classTyCon cls
, Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
else checkRecTc rec_clss tc
- = mentions_ip rec_clss' mb_str_ty cls tys
+ = mentions_ip rec_clss' str_cond ty_cond cls tys
| otherwise
= False -- Includes things like (D []) where D is
-- a Constraint-ranged family; #7785
@@ -429,7 +435,38 @@ Small worries (Sept 20):
* The superclass hunt stops when it encounters the same class again,
but in principle we could have the same class, differently instantiated,
and the second time it could have an implicit parameter
-I'm going to treat these as problems for another day. They are all exotic. -}
+I'm going to treat these as problems for another day. They are all exotic.
+
+Note [Using typesAreApart when calling mentionsIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call 'mentionsIP' in two situations:
+
+ (1) to check that a predicate does not contain any implicit parameters
+ IP str ty, for a fixed literal str and any type ty,
+ (2) to check that a predicate does not contain any HasCallStack or
+ HasExceptionContext constraints.
+
+In both of these cases, we want to be sure, so we should be conservative:
+
+ For (1), the predicate might contain an implicit parameter IP Str a, where
+ Str is a type family such as:
+
+ type family MyStr where MyStr = "abc"
+
+ To safeguard against this (niche) situation, instead of doing a simple
+ type equality check, we use 'typesAreApart'. This allows us to recognise
+ that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.
+
+ For (2), we similarly might have
+
+ type family MyCallStack where MyCallStack = CallStack
+
+ Again, here we use 'typesAreApart'. This allows us to see that
+
+ (?foo :: MyCallStack)
+
+ is indeed a CallStack constraint, hidden under a type family.
+-}
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -2659,6 +2659,7 @@ tyConStupidTheta :: TyCon -> [PredType]
tyConStupidTheta tc@(TyCon { tyConDetails = details })
| AlgTyCon {algTcStupidTheta = stupid} <- details = stupid
| PrimTyCon {} <- details = []
+ | PromotedDataCon {} <- details = []
| otherwise = pprPanic "tyConStupidTheta" (ppr tc)
-- | Extract the 'TyVar's bound by a vanilla type synonym
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Core.InstEnv ( DFunInstType )
import GHC.Core.Class
import GHC.Core.Predicate
import GHC.Core.Multiplicity ( scaledThing )
-import GHC.Core.Unify ( ruleMatchTyKiX )
+import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart )
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -105,21 +105,25 @@ updInertDicts :: DictCt -> TcS ()
updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
= do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
-> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
-- Update /both/ inert_cans /and/ inert_solved_dicts.
updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }
- | otherwise
+ inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
+ , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
+ | otherwise
-> return ()
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
where
- not_ip_for :: Type -> DictCt -> Bool
- not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not (mentionsIP str_ty cls tys)
+ -- Does this class constraint or any of its superclasses mention
+ -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
+ does_not_mention_ip_for :: Type -> DictCt -> Bool
+ does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
+ = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
+ -- See Note [Using typesAreApart when calling mentionsIP]
+ -- in GHC.Core.Predicate
canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt
-- Once-only processing of Dict constraints:
@@ -201,7 +205,7 @@ in two places:
* In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have
(?x :: ty) in the inert set and an identical (?x :: ty) as the work item.
-* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any
+* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
* Wrinkle (SIP1): we must be careful of superclasses. Consider
@@ -221,7 +225,7 @@ in two places:
An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
But it could happen for `class xx => D xx where ...` and the constraint D
(?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explorered.
+ implicit parameter constraints) is not well explored.
Example in #14218, and #23761
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -158,7 +158,7 @@ import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.Unify
-import GHC.Builtin.Names ( unsatisfiableClassNameKey )
+import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )
import GHC.Core.Type
import GHC.Core.TyCo.Rep as Rep
@@ -168,6 +168,7 @@ import GHC.Core.Predicate
import GHC.Core.Reduction
import GHC.Core.Class
import GHC.Core.TyCon
+import GHC.Core.Unify (typesAreApart)
import GHC.Types.Name
import GHC.Types.TyThing
@@ -177,13 +178,13 @@ import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
import GHC.Types.Unique.Set( elementOfUniqSet )
-import GHC.Unit.Module ( HasModule, getModule, extractModule )
+import GHC.Unit.Module ( HasModule, getModule, extractModule, primUnit, moduleUnit, ghcInternalUnit, bignumUnit)
import qualified GHC.Rename.Env as TcM
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
-import GHC.Utils.Misc (HasDebugCallStack)
+import GHC.Utils.Misc (HasDebugCallStack, (<||>))
import GHC.Data.Bag as Bag
import GHC.Data.Pair
@@ -478,14 +479,92 @@ getSafeOverlapFailures
updSolvedDicts :: InstanceWhat -> DictCt -> TcS ()
-- Conditionally add a new item in the solved set of the monad
-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
-updSolvedDicts what dict_ct@(DictCt { di_ev = ev })
+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
| isWanted ev
, instanceReturnsDictCon what
- = do { traceTcS "updSolvedDicts:" $ ppr dict_ct
+ = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
+ ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
+ ; let contains_callstack_or_exceptionCtx =
+ mentionsIP
+ (const True)
+ -- NB: the name of the call-stack IP is irrelevant
+ -- e.g (?foo :: CallStack) counts!
+ (is_callstack <||> is_exceptionCtx)
+ cls tys
+ -- See Note [Don't add HasCallStack constraints to the solved set]
+ ; unless contains_callstack_or_exceptionCtx $
+ do { traceTcS "updSolvedDicts:" $ ppr dict_ct
; updInertSet $ \ ics ->
- ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } }
+ ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }
+ } }
| otherwise
= return ()
+ where
+
+ -- Return a predicate that decides whether a type is CallStack
+ -- or ExceptionContext, accounting for e.g. type family reduction, as
+ -- per Note [Using typesAreApart when calling mentionsIP].
+ --
+ -- See Note [Using isCallStackTy in mentionsIP].
+ is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
+ is_tyConTy is_eq tc_name
+ = do { mb_tc <- wrapTcS $ do
+ mod <- tcg_mod <$> TcM.getGblEnv
+ if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]
+ then return Nothing
+ else Just <$> TcM.tcLookupTyCon tc_name
+ ; case mb_tc of
+ Just tc ->
+ return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))
+ Nothing ->
+ return is_eq
+ }
+
+{- Note [Don't add HasCallStack constraints to the solved set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not add solved Wanted dictionaries that mention HasCallStack constraints
+to the solved set, or we might fail to accumulate the proper call stack, as was
+reported in #25529.
+
+Recall that HasCallStack constraints (and the related HasExceptionContext
+constraints) are implicit parameter constraints, and are accumulated as per
+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.
+
+When we solve a Wanted that contains a HasCallStack constraint, we don't want
+to cache the result, because re-using that solution means re-using the call-stack
+in a different context!
+
+See also Note [Shadowing of implicit parameters], which deals with a similar
+problem with Given implicit parameter constraints.
+
+Note [Using isCallStackTy in mentionsIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To implement Note [Don't add HasCallStack constraints to the solved set],
+we need to check whether a constraint contains a HasCallStack or HasExceptionContext
+constraint. We do this using the 'mentionsIP' function, but as per
+Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
+
+ mentionsIP
+ (const True) -- (ignore the implicit parameter string)
+ (isCallStackTy <||> isExceptionContextTy)
+
+because this does not account for e.g. a type family that reduces to CallStack.
+The predicate we want to use instead is:
+
+ \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)
+
+However, this is made difficult by the fact that CallStack and ExceptionContext
+are not wired-in types; they are only known-key. This means we must look them
+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle
+of typechecking ghc-internal and these data-types have not been typechecked yet!
+
+In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'
+logic.
+
+Note that it would be somewhat painful to wire-in ExceptionContext: at the time
+of writing (March 2025), this would require wiring in the ExceptionAnnotation
+class, as well as SomeExceptionAnnotation, which is a data type with existentials.
+-}
getSolvedDicts :: TcS (DictMap DictCt)
getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }
=====================================
compiler/GHC/Tc/Solver/Types.hs
=====================================
@@ -166,7 +166,7 @@ Suppose f :: HasCallStack => blah. Then
IP "callStack" CallStack
See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by
+* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by
pushing the call-site info on the stack, and changing the CtOrigin
to record that has been done.
Bind: s1 = pushCallStack <site-info> s2
=====================================
configure.ac
=====================================
@@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.10.2], [glasgow-ha
AC_CONFIG_MACRO_DIRS([m4])
# Set this to YES for a released version, otherwise NO
-: ${RELEASE=YES}
+: ${RELEASE=NO}
# The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line
# above. If this is not a released version, then we will append the
=====================================
docs/users_guide/9.10.3-notes.rst
=====================================
@@ -0,0 +1,165 @@
+.. _release-9-10-3:
+
+Version 9.10.3
+===============
+The significant changes to the various parts of the compiler are listed in the
+following sections. See the `migration guide
+<https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.10>`_ on the GHC Wiki
+for specific guidance on migrating programs to this release.
+
+
+Compiler
+~~~~~~~~
+
+- Don't cache solved [W] HasCallStack constraints to avoid re-using old
+ call-stacks instead of constructing new ones. (:ghc-ticket:`25529`)
+
+- Fix EmptyCase panic in tcMatches when \case{} is checked against a function
+ type preceded by invisible forall. (:ghc-ticket:`25960`)
+
+- Fix panic triggered by combination of \case{} and forall t ->. (:ghc-ticket:`25004`)
+
+- Fix GHC.SysTools.Ar archive member size writing logic that was emitting wrong
+ archive member sizes in headers. (:ghc-ticket:`26120`, :ghc-ticket:`22586`)
+
+- Fix multiple bugs in name resolution of subordinate import lists related to
+ type namespace specifiers and hiding clauses. (:ghc-ticket:`22581`, :ghc-ticket:`25983`, :ghc-ticket:`25984`, :ghc-ticket:`25991`)
+
+- Use mkTrAppChecked in ds_ev_typeable to avoid false negatives for type
+ equality involving function types. (:ghc-ticket:`25998`)
+
+- Fix bytecode generation for ``tagToEnum# <LITERAL>``. (:ghc-ticket:`25975`)
+
+- Don't report used duplicate record fields as unused. (:ghc-ticket:`24035`)
+
+- Propagate long distance info to guarded let binds for better pattern-match
+ checking warnings. (:ghc-ticket:`25749`)
+
+- Prevent incorrect unpacking optimizations for GADTs with multiple constructors. (:ghc-ticket:`25672`)
+
+- Introduce a separate argument limit for forced specs via SPEC argument with
+ warning when limit is exceeded. (:ghc-ticket:`25197`)
+
+Build system and packaging
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- 9.10 hadrian can build with Cabal-3.12.1. (:ghc-ticket:`25605`)
+
+- GHC settings: always unescape escaped spaces to fix handling of spaces in
+ executable paths. (:ghc-ticket:`25204`)
+
+Native code generator backend
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- x86 NCG: Fix code generation of bswap64 on i386. (:ghc-ticket:`25601`)
+
+- AArch64 NCG: Fix sub-word arithmetic right shift by zero-extending sub-word
+ values. (:ghc-ticket:`26061`)
+
+- NCG: AArch64 - Add -finter-module-far-jumps flag for modules with far jumps
+ outside the current module. (:ghc-ticket:`24648`)
+
+LLVM backend
+~~~~~~~~~~~~
+
+- LLVM: fix typo in padLiveArgs that was incorrectly computing too many padding
+ registers causing segfaults. (:ghc-ticket:`25770`, :ghc-ticket:`25773`)
+
+- llvmGen: Fix linkage of built-in arrays to use Appending linkage instead of
+ Internal. (:ghc-ticket:`25769`)
+
+- llvmGen: Fix built-in variable predicate to check for `@llvm` rather than
+ `$llvm`.
+
+WebAssembly backend
+~~~~~~~~~~~~~~~~~~~
+
+- wasm: use primitive opcodes for fabs and sqrt operations.
+
+Runtime system
+~~~~~~~~~~~~~~
+
+- rts: Implement WEAK EXTERNAL undef redirection by target symbol name.
+
+- rts: Handle API set symbol versioning conflicts.
+
+- rts: fix rts_clearMemory logic when sanity checks are enabled. (:ghc-ticket:`26011`)
+
+- rts/linker: Improve efficiency of proddable blocks structure by using binary
+ search instead of linked lists for better performance with split sections. (:ghc-ticket:`26009`)
+
+- rts/linker/PEi386: Don't repeatedly load DLLs by maintaining a hash-set of
+ loaded DLL names. (:ghc-ticket:`26009`, :ghc-ticket:`26052`)
+
+- rts/linker: Don't fail due to RTLD_NOW by attempting eager binding first,
+ then reverting to lazy binding on failure. (:ghc-ticket:`25943`)
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+- base: Expose Backtraces constructor and fields. (:ghc-ticket:`26049`)
+
+- base: Note strictness changes made in 4.16.0.0. (:ghc-ticket:`25886`)
+
+- Fix bugs in ``integerRecipMod`` and ``integerPowMod`` return values. (:ghc-ticket:`26017`)
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+- perf: Replace uses of genericLength with strictGenericLength to reduce time
+ spent in 'assembleBCOs' and allocations. (:ghc-ticket:`25706`)
+
+Build tools
+~~~~~~~~~~~
+
+- configure: Drop probing of ld.gold since `gold` has been dropped from
+ binutils-2.44. (:ghc-ticket:`25716`)
+
+- get-win32-tarballs.py: List tarball files to be downloaded if we cannot find
+ them. (:ghc-ticket:`25929`)
+
+- hp2ps Utilities.c: include stdlib.h instead of extern malloc and realloc.
+
+Included libraries
+~~~~~~~~~~~~~~~~~~
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/stm/stm.cabal: Dependency of ``haskeline`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
\ No newline at end of file
=====================================
hadrian/hadrian.cabal
=====================================
@@ -152,7 +152,7 @@ executable hadrian
, TypeOperators
other-extensions: MultiParamTypeClasses
, TypeFamilies
- build-depends: Cabal >= 3.10 && < 3.11
+ build-depends: Cabal (>= 3.10 && < 3.11) || (>= 3.12.1 && < 3.13)
, base >= 4.11 && < 5
, bytestring >= 0.10 && < 0.13
, containers >= 0.5 && < 0.8
=====================================
hadrian/src/Context.hs
=====================================
@@ -9,7 +9,7 @@ module Context (
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir,
pkgHaddockFile, pkgRegisteredLibraryFile, pkgRegisteredLibraryFileName,
pkgLibraryFile, pkgGhciLibraryFile,
- pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir,
+ pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir, distDynDir,
haddockStatsFilesDir
) where
@@ -20,7 +20,8 @@ import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Oracles.Setting
import GHC.Toolchain.Target (Target(..))
-import GHC.Platform.ArchOS
+import Hadrian.Oracles.Cabal
+import Hadrian.Haskell.Cabal.Type
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
@@ -62,12 +63,15 @@ libPath Context {..} = buildRoot <&> (-/- (stageString stage -/- "lib"))
--
-- We preform some renaming to accommodate Cabal's slightly different naming
-- conventions (see 'cabalOsString' and 'cabalArchString').
-distDir :: Stage -> Action FilePath
-distDir st = do
- version <- ghcVersionStage st
- targetOs <- cabalOsString . stringEncodeOS . archOS_OS . tgtArchOs <$> targetStage st
- targetArch <- cabalArchString . stringEncodeArch . archOS_arch . tgtArchOs <$> targetStage st
- return $ targetArch ++ "-" ++ targetOs ++ "-ghc-" ++ version
+distDir :: Context -> Action FilePath
+distDir c = do
+ cd <- readContextData c
+ return (contextLibdir cd)
+
+distDynDir :: Context -> Action FilePath
+distDynDir c = do
+ cd <- readContextData c
+ return (contextDynLibdir cd)
pkgFileName :: Context -> Package -> String -> String -> Action FilePath
pkgFileName context package prefix suffix = do
@@ -104,13 +108,12 @@ pkgHaddockFile Context {..} = do
-- @_build/stage1/lib/x86_64-linux-ghc-8.9.0/array-0.5.1.0/libHSarray-0.5.4.0.a@
pkgRegisteredLibraryFile :: Context -> Action FilePath
pkgRegisteredLibraryFile context@Context {..} = do
- libDir <- libPath context
- pkgId <- pkgUnitId stage package
fileName <- pkgRegisteredLibraryFileName context
- distDir <- distDir stage
+ distDir <- distDir context
+ distDynDir <- distDynDir context
return $ if Dynamic `wayUnit` way
- then libDir -/- distDir -/- fileName
- else libDir -/- distDir -/- pkgId -/- fileName
+ then distDynDir -/- fileName
+ else distDir -/- fileName
-- | Just the final filename portion of pkgRegisteredLibraryFile
pkgRegisteredLibraryFileName :: Context -> Action FilePath
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -254,6 +254,7 @@ resolveContextData context@Context {..} = do
pdi <- liftIO $ getHookedBuildInfo [pkgPath package, cPath -/- "build"]
let pd' = C.updatePackageDescription pdi (C.localPkgDescr lbi)
lbi' = lbi { C.localPkgDescr = pd' }
+ pkgDbPath <- packageDbPath (PackageDbLoc stage iplace)
-- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
-- See: https://github.com/snowleopard/hadrian/issues/548
@@ -302,6 +303,8 @@ resolveContextData context@Context {..} = do
| takeExtension fp `elem` [".cpp", ".cxx", ".c++"]= CppMain
| otherwise = CMain
+ install_dirs = absoluteInstallDirs pd' lbi' (CopyToDb pkgDbPath)
+
main_src = fmap (first C.display) mainIs
cdata = ContextData
{ dependencies = deps
@@ -343,7 +346,10 @@ resolveContextData context@Context {..} = do
, depLdOpts = forDeps Installed.ldOptions
, buildGhciLib = C.withGHCiLib lbi'
, frameworks = C.frameworks buildInfo
- , packageDescription = pd' }
+ , packageDescription = pd'
+ , contextLibdir = libdir install_dirs
+ , contextDynLibdir = dynlibdir install_dirs
+ }
in return cdata
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Type.hs
=====================================
@@ -70,6 +70,10 @@ data ContextData = ContextData
, buildGhciLib :: Bool
, frameworks :: [String]
, packageDescription :: PackageDescription
+ -- The location where normal library files go
+ , contextLibdir :: FilePath
+ -- The location where dynamic libraries go
+ , contextDynLibdir :: FilePath
} deriving (Eq, Generic, Show, Typeable)
instance Binary PackageData
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -146,7 +146,7 @@ bindistRules = do
phony "binary-dist-dir" $ do
version <- setting ProjectVersion
targetPlatform <- setting TargetPlatformFull
- distDir <- Context.distDir Stage1
+ distDir <- Context.distDir (vanillaContext Stage1 rts)
rtsDir <- pkgUnitId Stage1 rts
-- let rtsDir = "rts"
=====================================
hadrian/src/Rules/CabalReinstall.hs
=====================================
@@ -10,7 +10,6 @@ import Utilities
import qualified System.Directory.Extra as IO
import Data.Either
import Rules.BinaryDist
-import Hadrian.Haskell.Cabal (pkgUnitId)
import Oracles.Setting
{-
@@ -53,13 +52,10 @@ cabalBuildRules = do
iserv_targets <- if cross then pure [] else iservBins
need (lib_targets ++ (map (\(_, p) -> p) (bin_targets ++ iserv_targets)))
- distDir <- Context.distDir Stage1
- rtsDir <- pkgUnitId Stage1 rts
+ distDir <- Context.distDir (vanillaContext Stage1 rts)
-- let rtsDir = "rts"
- let ghcBuildDir = root -/- stageString Stage1
- rtsIncludeDir = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
- -/- "include"
+ let rtsIncludeDir = distDir -/- "include"
libdir <- liftIO . IO.makeAbsolute =<< stageLibPath Stage1
work_dir <- liftIO $ IO.makeAbsolute $ root -/- "stage-cabal"
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -182,11 +182,12 @@ buildConfFinal rs context@Context {..} _conf = do
--
-- so that if any change ends up modifying a library (but not its .conf
-- file), we still rebuild things that depend on it.
- dir <- (-/-) <$> libPath context <*> distDir stage
+ dir <- distDir context
+ dyndir <- distDynDir context
pkgid <- pkgUnitId stage package
files <- liftIO $
- (++) <$> getDirectoryFilesIO "." [dir -/- "*libHS"++pkgid++"*"]
- <*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
+ (++) <$> getDirectoryFilesIO "." [dyndir -/- "*libHS"++pkgid++"*"]
+ <*> getDirectoryFilesIO "." [dir -/- "**"]
produces files
buildConfInplace :: [(Resource, Int)] -> Context -> FilePath -> Action ()
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -154,10 +154,9 @@ needRtsSymLinks :: Stage -> Set.Set Way -> Action ()
needRtsSymLinks stage rtsWays
= forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do
let ctx = Context stage rts way Final
- libPath <- libPath ctx
- distDir <- distDir stage
+ distDir <- distDynDir ctx
rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
- need [removeRtsDummyVersion (libPath </> distDir </> rtsLibFile)]
+ need [removeRtsDummyVersion (distDir </> rtsLibFile)]
prefix, versionlessPrefix :: String
versionlessPrefix = "libHSrts"
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -98,9 +98,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
-- Relative path from the output (rpath $ORIGIN).
originPath <- dropFileName <$> getOutput
context <- getContext
- libPath' <- expr (libPath context)
- st <- getStage
- distDir <- expr (Context.distDir st)
+ distPath <- expr (Context.distDynDir context)
useSystemFfi <- expr (flag UseSystemFfi)
buildPath <- getBuildPath
@@ -112,7 +110,6 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
let
dynamic = Dynamic `wayUnit` way
- distPath = libPath' -/- distDir
originToLibsDir = makeRelativeNoSysLink originPath distPath
rpath
-- Programs will end up in the bin dir ($ORIGIN) and will link to
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1493,7 +1493,7 @@ async def do_test(name: TestName,
dst_makefile = in_testdir('Makefile')
if src_makefile.exists():
makefile = src_makefile.read_text(encoding='UTF-8')
- makefile = re.sub('TOP=.*', 'TOP=%s' % config.top, makefile, 1)
+ makefile = re.sub('TOP=.*', 'TOP=%s' % config.top, makefile, count=1)
dst_makefile.write_text(makefile, encoding='UTF-8')
if opts.pre_cmd:
=====================================
testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
=====================================
@@ -13,13 +13,13 @@ Building library 'q' instantiated with
for bkpcabal08-0.1.0.0...
[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
-[4 of 4] Instantiating bkpcabal08-0.1.0.0-5O1mUtZZLBeDZEqqtwJcCj-p
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-Asivy2QkF0WEbGENiw5nyj-p
Preprocessing library 'q' for bkpcabal08-0.1.0.0...
Building library 'q' instantiated with
- A = bkpcabal08-0.1.0.0-DlVb5PcmUolGCHYbfTL7EP-impl:A
- B = bkpcabal08-0.1.0.0-DlVb5PcmUolGCHYbfTL7EP-impl:B
+ A = bkpcabal08-0.1.0.0-BznDTmYyvWf7fdEdPEncB4-impl:A
+ B = bkpcabal08-0.1.0.0-BznDTmYyvWf7fdEdPEncB4-impl:B
for bkpcabal08-0.1.0.0...
-[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-LFiTKyjPqyn9yyuysCoVKg-q+5IA1jA4bEzCFcXtraqAC38/A.o ) [Prelude package changed]
-[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-LFiTKyjPqyn9yyuysCoVKg-q+5IA1jA4bEzCFcXtraqAC38/B.o ) [Prelude package changed]
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-BOgmYfE3t0l9LsOUH0dl5H-q+sLNLgjkt61DMZK9wGbx81/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-BOgmYfE3t0l9LsOUH0dl5H-q+sLNLgjkt61DMZK9wGbx81/B.o ) [Prelude package changed]
Preprocessing library 'r' for bkpcabal08-0.1.0.0...
Building library 'r' for bkpcabal08-0.1.0.0...
=====================================
testsuite/tests/driver/T20604/T20604.stdout
=====================================
@@ -1,11 +1,10 @@
A1
A
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-prim-0.10.0-inplace-ghc9.9.20230815.so" 1403aed32fb9af243c4cc949007c846c
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-bignum-1.3-inplace-ghc9.9.20230815.so" 54293f8faab737bac998f6e1a1248db8
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-internal-0.1.0.0-inplace-ghc9.9.20230815.so" a5c0e962d84d9044d44df4698becddcc
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSbase-4.19.0.0-inplace-ghc9.9.20230815.so" 4a90ed136fe0f89e5d0360daded517bd
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSghc-boot-th-9.9-inplace-ghc9.9.20230815.so" e338655f71b1d37fdfdd2504b7de6e76
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSarray-0.5.6.0-inplace-ghc9.9.20230815.so" 6943478e8adaa043abf7a2b38dd435a2
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSdeepseq-1.5.0.0-inplace-ghc9.9.20230815.so" 9974eb196694990ac6bb3c2591405de0
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHSpretty-1.1.3.6-inplace-ghc9.9.20230815.so" 1eefc21514f5584086f62b70aa554b7d
-addDependentFile "/home/ben/ghc/ghc-compare-2/_build/stage1/lib/../lib/x86_64-linux-ghc-9.9.20230815/libHStemplate-haskell-2.21.0.0-inplace-ghc9.9.20230815.so" f85c86eb94dcce1eacd739b6e991ba2d
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-prim-0.12.0-inplace-ghc9.10.2.20250724.so" 0b7cbf5659e1fd221ea306e2da08c7d3
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-bignum-1.3-inplace-ghc9.10.2.20250724.so" 1c29a409bcfbc31a3cfc2ded7c1d5530
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-internal-9.1002.0-inplace-ghc9.10.2.20250724.so" 9606aee1cbbee934848aa85568563754
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSbase-4.20.1.0-inplace-ghc9.10.2.20250724.so" 5d1ab384becff6d4b20bae121d55fbc8
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSghc-boot-th-9.10.2.20250724-inplace-ghc9.10.2.20250724.so" 930b5206ff48d75ba522e582262695a8
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSdeepseq-1.5.2.0-inplace-ghc9.10.2.20250724.so" db23e7880c9a9fee0d494b48294c3487
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHSpretty-1.1.3.6-inplace-ghc9.10.2.20250724.so" ad484cfb103f02509b1be6abcf2a402f
+addDependentFile "/home/zubin/ghcs/unicode-lex/_build_/stage1/lib/../lib/x86_64-linux-ghc-9.10.2.20250724/libHStemplate-haskell-2.22.0.0-inplace-ghc9.10.2.20250724.so" 50b2cb166e6e5293c24be374ffac2ade
=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -27,12 +27,12 @@ instance [safe] Eq w => Eq (Maybe w)
-- Defined in ‘GHC.Internal.Maybe’
instance GHC.Internal.Generics.Generic [w]
-- Defined in ‘GHC.Internal.Generics’
-instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
-instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
instance Eq w => Eq [w] -- Defined in ‘GHC.Classes’
instance Ord w => Ord [w] -- Defined in ‘GHC.Classes’
instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
+instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
+instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
instance [safe] MyShow w => MyShow [w]
-- Defined at ghci064.hs:8:10
instance GHC.Internal.Generics.Generic [T]
=====================================
testsuite/tests/plugins/plugins10.stdout
=====================================
@@ -7,6 +7,8 @@ interfacePlugin: GHC.Internal.Float
interfacePlugin: GHC.Prim.Ext
interfacePlugin: Language.Haskell.TH.Syntax
typeCheckPlugin (rn)
+interfacePlugin: GHC.Internal.Stack.Types
+interfacePlugin: GHC.Internal.Exception.Context
typeCheckPlugin (tc)
parsePlugin(a)
typeCheckPlugin (rn)
=====================================
testsuite/tests/plugins/static-plugins.stdout
=====================================
@@ -8,6 +8,8 @@ interfacePlugin: GHC.Internal.System.IO
interfacePlugin: GHC.Types
interfacePlugin: GHC.Internal.Show
typeCheckPlugin (rn)
+interfacePlugin: GHC.Internal.Stack.Types
+interfacePlugin: GHC.Internal.Exception.Context
interfacePlugin: GHC.Internal.TopHandler
typeCheckPlugin (tc)
interfacePlugin: GHC.CString
=====================================
testsuite/tests/typecheck/should_run/T25529.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+
+module Main where
+
+import GHC.Stack (HasCallStack, CallStack, SrcLoc(srcLocStartLine, srcLocStartCol), callStack, getCallStack)
+
+main :: IO ()
+main =
+ let ?myImplicitParam = ()
+ in run action
+
+type MyConstraints = (HasCallStack, ?myImplicitParam :: ())
+
+action :: MyConstraints => IO ()
+action = run $ pure ()
+
+-- | Print the current call stack and then run an action.
+run ::
+ MyConstraints =>
+ IO a ->
+ IO a
+run action = do
+ let prettyCallStack = unlines $ map prettyCallStackEntry $ getCallStack callStack
+ prettyCallStackEntry (name, loc) =
+ name
+ <> ", called at "
+ <> show (srcLocStartLine loc)
+ <> ":"
+ <> show (srcLocStartCol loc)
+ putStrLn "============================================================"
+ putStrLn prettyCallStack
+ action
=====================================
testsuite/tests/typecheck/should_run/T25529.stdout
=====================================
@@ -0,0 +1,7 @@
+============================================================
+run, called at 11:7
+
+============================================================
+run, called at 16:10
+action, called at 11:11
+
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -170,6 +170,7 @@ test('T22510', normal, compile_and_run, [''])
test('T21973a', [exit_code(1)], compile_and_run, [''])
test('T21973b', normal, compile_and_run, [''])
test('T23761', normal, compile_and_run, [''])
+test('T25529', normal, compile_and_run, [''])
test('T23761b', normal, compile_and_run, [''])
test('T17594e', normal, compile_and_run, [''])
test('T25998', normal, compile_and_run, [''])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit f6116257ff838bb0b9def2c49d2f629756527ad2
+Subproject commit 00ac9eec76037ebf4e9b0b84f50675449edc5f51
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0450ef3cbff1bda4d0674369951616…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0450ef3cbff1bda4d0674369951616…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Deleted branch wip/sol/add-rendered-to-json-diagnostics
by Simon Hengel (＠sol) 24 Jul '25
by Simon Hengel (＠sol) 24 Jul '25
24 Jul '25
Simon Hengel deleted branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
24 Jul '25
Simon Hengel deleted branch wip/sol/pre-processors-errors at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] rts/Interpreter: Factor out ctoi tuple info tables into data
by Marge Bot (＠marge-bot) 24 Jul '25
by Marge Bot (＠marge-bot) 24 Jul '25
24 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d2b89603 by Ben Gamari at 2025-07-24T06:12:47-04:00
rts/Interpreter: Factor out ctoi tuple info tables into data
Instead of a massive case let's put this into data which we can reuse
elsewhere.
- - - - -
1 changed file:
- rts/Interpreter.c
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -473,6 +473,72 @@ void interp_shutdown( void ){
#endif
+const StgPtr ctoi_tuple_infos[] = {
+ (StgPtr) &stg_ctoi_t0_info,
+ (StgPtr) &stg_ctoi_t1_info,
+ (StgPtr) &stg_ctoi_t2_info,
+ (StgPtr) &stg_ctoi_t3_info,
+ (StgPtr) &stg_ctoi_t4_info,
+ (StgPtr) &stg_ctoi_t5_info,
+ (StgPtr) &stg_ctoi_t6_info,
+ (StgPtr) &stg_ctoi_t7_info,
+ (StgPtr) &stg_ctoi_t8_info,
+ (StgPtr) &stg_ctoi_t9_info,
+ (StgPtr) &stg_ctoi_t10_info,
+ (StgPtr) &stg_ctoi_t11_info,
+ (StgPtr) &stg_ctoi_t12_info,
+ (StgPtr) &stg_ctoi_t13_info,
+ (StgPtr) &stg_ctoi_t14_info,
+ (StgPtr) &stg_ctoi_t15_info,
+ (StgPtr) &stg_ctoi_t16_info,
+ (StgPtr) &stg_ctoi_t17_info,
+ (StgPtr) &stg_ctoi_t18_info,
+ (StgPtr) &stg_ctoi_t19_info,
+ (StgPtr) &stg_ctoi_t20_info,
+ (StgPtr) &stg_ctoi_t21_info,
+ (StgPtr) &stg_ctoi_t22_info,
+ (StgPtr) &stg_ctoi_t23_info,
+ (StgPtr) &stg_ctoi_t24_info,
+ (StgPtr) &stg_ctoi_t25_info,
+ (StgPtr) &stg_ctoi_t26_info,
+ (StgPtr) &stg_ctoi_t27_info,
+ (StgPtr) &stg_ctoi_t28_info,
+ (StgPtr) &stg_ctoi_t29_info,
+ (StgPtr) &stg_ctoi_t30_info,
+ (StgPtr) &stg_ctoi_t31_info,
+ (StgPtr) &stg_ctoi_t32_info,
+ (StgPtr) &stg_ctoi_t33_info,
+ (StgPtr) &stg_ctoi_t34_info,
+ (StgPtr) &stg_ctoi_t35_info,
+ (StgPtr) &stg_ctoi_t36_info,
+ (StgPtr) &stg_ctoi_t37_info,
+ (StgPtr) &stg_ctoi_t38_info,
+ (StgPtr) &stg_ctoi_t39_info,
+ (StgPtr) &stg_ctoi_t40_info,
+ (StgPtr) &stg_ctoi_t41_info,
+ (StgPtr) &stg_ctoi_t42_info,
+ (StgPtr) &stg_ctoi_t43_info,
+ (StgPtr) &stg_ctoi_t44_info,
+ (StgPtr) &stg_ctoi_t45_info,
+ (StgPtr) &stg_ctoi_t46_info,
+ (StgPtr) &stg_ctoi_t47_info,
+ (StgPtr) &stg_ctoi_t48_info,
+ (StgPtr) &stg_ctoi_t49_info,
+ (StgPtr) &stg_ctoi_t50_info,
+ (StgPtr) &stg_ctoi_t51_info,
+ (StgPtr) &stg_ctoi_t52_info,
+ (StgPtr) &stg_ctoi_t53_info,
+ (StgPtr) &stg_ctoi_t54_info,
+ (StgPtr) &stg_ctoi_t55_info,
+ (StgPtr) &stg_ctoi_t56_info,
+ (StgPtr) &stg_ctoi_t57_info,
+ (StgPtr) &stg_ctoi_t58_info,
+ (StgPtr) &stg_ctoi_t59_info,
+ (StgPtr) &stg_ctoi_t60_info,
+ (StgPtr) &stg_ctoi_t61_info,
+ (StgPtr) &stg_ctoi_t62_info,
+};
+
#if defined(PROFILING)
//
@@ -1828,82 +1894,11 @@ run_BCO:
SpW(-1) = BCO_PTR(o_tuple_bco);
SpW(-2) = tuple_info;
SpW(-3) = BCO_PTR(o_bco);
- W_ ctoi_t_offset;
int tuple_stack_words = (tuple_info >> 24) & 0xff;
- switch(tuple_stack_words) {
- case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break;
- case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break;
- case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break;
- case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break;
- case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break;
- case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break;
- case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break;
- case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break;
- case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break;
- case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break;
-
- case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
- case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
- case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
- case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
- case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
- case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
- case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
- case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
- case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
- case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
-
- case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
- case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
- case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
- case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
- case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
- case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
- case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
- case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
- case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
- case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
-
- case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
- case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
- case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
- case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
- case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
- case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
- case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
- case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
- case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
- case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
-
- case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
- case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
- case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
- case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
- case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
- case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
- case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
- case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
- case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
- case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
-
- case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
- case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
- case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
- case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
- case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
- case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
- case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
- case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
- case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
- case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
-
- case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
- case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
- case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
-
- default: barf("unsupported tuple size %d", tuple_stack_words);
+ if (tuple_stack_words > 62) {
+ barf("unsupported tuple size %d", tuple_stack_words);
}
-
+ W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
goto nextInsn;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2b89603425b6d08df199deb7b84cfd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2b89603425b6d08df199deb7b84cfd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0