[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 2 commits: Implement `decode` in terms of `decodeStackWithIpe`
by Hannes Siebenhandl (＠fendor) 25 Aug '25
by Hannes Siebenhandl (＠fendor) 25 Aug '25
25 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
89b43a1f by fendor at 2025-08-25T17:41:59+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
ff14c7a2 by fendor at 2025-08-25T17:41:59+02:00
Remove stg_decodeStackzh
- - - - -
15 changed files:
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,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_ptr_ipe_key;
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_ptr_ipe_key = %INFO_PTR(UNTAG(p));
+ return (info_struct, info_ptr_ipe_key);
}
// (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/cbits/Stack_c.c
=====================================
@@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
const StgInfoTable *getItbl(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
return get_itbl(closure);
-};
+}
StgWord getBitmapSize(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1245,9 +1245,21 @@ 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$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh,
+ h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh,
+ h$isArgGenBigRetFunTypezh,
+ h$getUnderflowFrameNextChunkzh,
+ h$getInfoTableAddrszh,
+ h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh
h$stg_cloneMyStackzh
- = h$stg_decodeStackzh
+ = h$advanceStackFrameLocationzh
+ = h$getStackFieldszh = h$getStackClosurezh
+ = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh
+ = h$isArgGenBigRetFunTypezh
+ = h$getUnderflowFrameNextChunkzh
+ = h$getInfoTableAddrszh
+ = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
import qualified GHC.Internal.Stack.CloneStack as CloneStack
+import qualified GHC.Internal.Stack.Decode as CloneStack
import qualified GHC.Internal.Stack.CCS as CCS
-- | How to collect a backtrace when an exception is thrown.
=====================================
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,16 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
+ -- * High-level stack decoders
+ decode,
decodeStack,
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackEntry,
)
where
@@ -23,7 +32,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 +54,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 +166,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_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
+ in
+ (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack stackSnapshot# =
@@ -279,18 +295,66 @@ 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 ->
+ -- ^ Decode the given 'StackFrame'.
+ (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
+ -- ^ How to handle 'UNDERFLOW_FRAME's.
+ (StackFrame -> Maybe InfoProv -> IO a) ->
+ -- ^ How to handle all other 'StackFrame' values.
+ IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+ (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
+ (unpackUnderflowFrame info m_info_prov)
+ (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' :: StgInfoTable -> IO StackFrame
- unpackStackFrame' info =
+ unpackStackFrame' ::
+ 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 +363,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 +382,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 +392,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 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 +422,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 +433,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',
@@ -383,7 +442,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
ANN_FRAME ->
let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
in
- pure $
+ mkStackFrameResult $
AnnFrame
{ info_tbl = info,
annotation = annotation
@@ -401,6 +460,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
@@ -413,19 +520,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]
@@ -436,3 +555,11 @@ 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
+-- ----------------------------------------------------------------------------
+
+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
=====================================
@@ -951,7 +951,6 @@ extern char **environ;
SymI_HasProto(lookupIPE) \
SymI_HasProto(sendCloneStackMessage) \
SymI_HasProto(cloneStack) \
- SymI_HasProto(decodeClonedStack) \
SymI_HasProto(getUnderflowFrameNextChunkzh) \
SymI_HasProto(getWordzh) \
SymI_HasProto(isArgGenBigRetFunTypezh) \
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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
=====================================
@@ -14715,7 +14715,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’
@@ -16171,7 +16171,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
=====================================
@@ -11936,7 +11936,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’
@@ -13411,7 +13411,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
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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/0f2012173c7322530f7fbda4f3fe0f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0f2012173c7322530f7fbda4f3fe0f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 2 commits: Implement `decode` in terms of `decodeStackWithIpe`
by Hannes Siebenhandl (＠fendor) 25 Aug '25
by Hannes Siebenhandl (＠fendor) 25 Aug '25
25 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
7ec787ab by fendor at 2025-08-25T17:37:01+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
0f201217 by fendor at 2025-08-25T17:37:01+02:00
Remove stg_decodeStackzh
- - - - -
15 changed files:
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,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_ptr_ipe_key;
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_ptr_ipe_key) = ccall getInfoTablePtrForIPE(UNTAG(p));
+ return (info_struct, info_ptr_ipe_key);
}
// (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/cbits/Stack_c.c
=====================================
@@ -26,10 +26,18 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
}
}
-// Only exists to make the get_itbl macro available in Haskell code (via FFI).
-const StgInfoTable *getItbl(StgClosure *closure) {
+/**
+ * Given a closure pointer, find the address to the StgInfoTable pointer
+ * that is they key for the closure's IPE info.
+ *
+ * @param closure Pointer to the closure to find the StgInfoTable for.
+ * @return Returns a (StgInfoTable *) that can be used for `lookupIPE`.
+ */
+const StgInfoTable *getInfoTablePtrForIPE(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
- return get_itbl(closure);
+ const StgInfoTable *info_entry;
+ info_entry = GET_INFO(closure);
+ return info_entry;
};
StgWord getBitmapSize(StgClosure *c) {
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1245,9 +1245,21 @@ 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$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh,
+ h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh,
+ h$isArgGenBigRetFunTypezh,
+ h$getUnderflowFrameNextChunkzh,
+ h$getInfoTableAddrszh,
+ h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh
h$stg_cloneMyStackzh
- = h$stg_decodeStackzh
+ = h$advanceStackFrameLocationzh
+ = h$getStackFieldszh = h$getStackClosurezh
+ = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh
+ = h$isArgGenBigRetFunTypezh
+ = h$getUnderflowFrameNextChunkzh
+ = h$getInfoTableAddrszh
+ = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
import qualified GHC.Internal.Stack.CloneStack as CloneStack
+import qualified GHC.Internal.Stack.Decode as CloneStack
import qualified GHC.Internal.Stack.CCS as CCS
-- | How to collect a backtrace when an exception is thrown.
=====================================
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,16 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
+ -- * High-level stack decoders
+ decode,
decodeStack,
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackEntry,
)
where
@@ -23,7 +32,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 +54,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 +166,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_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
+ in
+ (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack stackSnapshot# =
@@ -279,18 +295,66 @@ 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 ->
+ -- ^ Decode the given 'StackFrame'.
+ (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
+ -- ^ How to handle 'UNDERFLOW_FRAME's.
+ (StackFrame -> Maybe InfoProv -> IO a) ->
+ -- ^ How to handle all other 'StackFrame' values.
+ IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+ (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
+ (unpackUnderflowFrame info m_info_prov)
+ (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' :: StgInfoTable -> IO StackFrame
- unpackStackFrame' info =
+ unpackStackFrame' ::
+ 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 +363,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 +382,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 +392,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 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 +422,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 +433,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',
@@ -383,7 +442,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
ANN_FRAME ->
let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
in
- pure $
+ mkStackFrameResult $
AnnFrame
{ info_tbl = info,
annotation = annotation
@@ -401,6 +460,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
@@ -413,19 +520,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]
@@ -436,3 +555,11 @@ 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
+-- ----------------------------------------------------------------------------
+
+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
=====================================
@@ -951,7 +951,6 @@ extern char **environ;
SymI_HasProto(lookupIPE) \
SymI_HasProto(sendCloneStackMessage) \
SymI_HasProto(cloneStack) \
- SymI_HasProto(decodeClonedStack) \
SymI_HasProto(getUnderflowFrameNextChunkzh) \
SymI_HasProto(getWordzh) \
SymI_HasProto(isArgGenBigRetFunTypezh) \
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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
=====================================
@@ -14715,7 +14715,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’
@@ -16171,7 +16171,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
=====================================
@@ -11936,7 +11936,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’
@@ -13411,7 +13411,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
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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/35d83bc515cd083c5e11e81ef60384…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/35d83bc515cd083c5e11e81ef60384…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 2 commits: Implement `decode` in terms of `decodeStackWithIpe`
by Hannes Siebenhandl (＠fendor) 25 Aug '25
by Hannes Siebenhandl (＠fendor) 25 Aug '25
25 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
da5d69c0 by fendor at 2025-08-25T17:34:24+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
35d83bc5 by fendor at 2025-08-25T17:34:24+02:00
Remove stg_decodeStackzh
- - - - -
15 changed files:
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,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) = ccall getInfoTablePtrForIPE(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/cbits/Stack_c.c
=====================================
@@ -26,10 +26,18 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
}
}
-// Only exists to make the get_itbl macro available in Haskell code (via FFI).
-const StgInfoTable *getItbl(StgClosure *closure) {
+/**
+ * Given a closure pointer, find the address to the StgInfoTable pointer
+ * that is they key for the closure's IPE info.
+ *
+ * @param closure Pointer to the closure to find the StgInfoTable for.
+ * @return Returns a (StgInfoTable *) that can be used for `lookupIPE`.
+ */
+const StgInfoTable *getInfoTablePtrForIPE(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
- return get_itbl(closure);
+ const StgInfoTable *info_entry;
+ info_entry = GET_INFO(closure);
+ return info_entry;
};
StgWord getBitmapSize(StgClosure *c) {
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1245,9 +1245,21 @@ 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$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh,
+ h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh,
+ h$isArgGenBigRetFunTypezh,
+ h$getUnderflowFrameNextChunkzh,
+ h$getInfoTableAddrszh,
+ h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh
h$stg_cloneMyStackzh
- = h$stg_decodeStackzh
+ = h$advanceStackFrameLocationzh
+ = h$getStackFieldszh = h$getStackClosurezh
+ = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh
+ = h$isArgGenBigRetFunTypezh
+ = h$getUnderflowFrameNextChunkzh
+ = h$getInfoTableAddrszh
+ = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
import qualified GHC.Internal.Stack.CloneStack as CloneStack
+import qualified GHC.Internal.Stack.Decode as CloneStack
import qualified GHC.Internal.Stack.CCS as CCS
-- | How to collect a backtrace when an exception is thrown.
=====================================
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,16 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
+ -- * High-level stack decoders
+ decode,
decodeStack,
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackEntry,
)
where
@@ -23,7 +32,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 +54,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 +166,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 +295,66 @@ 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 ->
+ -- ^ Decode the given 'StackFrame'.
+ (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
+ -- ^ How to handle 'UNDERFLOW_FRAME's.
+ (StackFrame -> Maybe InfoProv -> IO a) ->
+ -- ^ How to handle all other 'StackFrame' values.
+ IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+ (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
+ (unpackUnderflowFrame info m_info_prov)
+ (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' :: StgInfoTable -> IO StackFrame
- unpackStackFrame' info =
+ unpackStackFrame' ::
+ 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 +363,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 +382,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 +392,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 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 +422,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 +433,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',
@@ -383,7 +442,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
ANN_FRAME ->
let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
in
- pure $
+ mkStackFrameResult $
AnnFrame
{ info_tbl = info,
annotation = annotation
@@ -401,6 +460,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
@@ -413,19 +520,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]
@@ -436,3 +555,11 @@ 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
+-- ----------------------------------------------------------------------------
+
+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
=====================================
@@ -951,7 +951,6 @@ extern char **environ;
SymI_HasProto(lookupIPE) \
SymI_HasProto(sendCloneStackMessage) \
SymI_HasProto(cloneStack) \
- SymI_HasProto(decodeClonedStack) \
SymI_HasProto(getUnderflowFrameNextChunkzh) \
SymI_HasProto(getWordzh) \
SymI_HasProto(isArgGenBigRetFunTypezh) \
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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
=====================================
@@ -14715,7 +14715,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’
@@ -16171,7 +16171,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
=====================================
@@ -11936,7 +11936,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’
@@ -13411,7 +13411,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
=====================================
@@ -11680,7 +11680,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’
@@ -13139,7 +13139,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/5d9aa6a41c2559c93ae556fb99de9f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d9aa6a41c2559c93ae556fb99de9f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 3 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Hannes Siebenhandl (＠fendor) 25 Aug '25
by Hannes Siebenhandl (＠fendor) 25 Aug '25
25 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
a03b407d by fendor at 2025-08-25T14:44:23+02:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
6277fc36 by fendor at 2025-08-25T17:31:14+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
5d9aa6a4 by fendor at 2025-08-25T17:31:14+02:00
Remove stg_decodeStackzh
- - - - -
54 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/ghc.cabal.in
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/ghci.cabal.in
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- rts/include/stg/MiscClosures.h
- 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
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7ea948991eb0fcee885a19ecfae83…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7ea948991eb0fcee885a19ecfae83…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26065] Correcting LLVM linking of Intel BMI intrinsics pdep{8,16} and pext{8,16}.
by recursion-ninja (＠recursion-ninja) 25 Aug '25
by recursion-ninja (＠recursion-ninja) 25 Aug '25
25 Aug '25
recursion-ninja pushed to branch wip/fix-26065 at Glasgow Haskell Compiler / GHC
Commits:
1db5d2a8 by Alex Washburn at 2025-08-25T10:32:53-04:00
Correcting LLVM linking of Intel BMI intrinsics pdep{8,16} and pext{8,16}.
This patch fixes #26045.
The LLVM interface does not expose bindings to:
- llvm.x86.bmi.pdep.8
- llvm.x86.bmi.pdep.16
- llvm.x86.bmi.pext.8
- llvm.x86.bmi.pext.16
So calls are instead made to llvm.x86.bmi.{pdep,pext}.32 in these cases,
with pre/post-operation truncation to constrain the logical value range.
- - - - -
4 changed files:
- compiler/GHC/CmmToLlvm/CodeGen.hs
- + testsuite/tests/llvm/should_run/T26065.hs
- + testsuite/tests/llvm/should_run/T26065.stdout
- testsuite/tests/llvm/should_run/all.T
Changes:
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -240,12 +240,25 @@ genCall (PrimTarget op@(MO_BRev w)) [dst] args =
genCallSimpleCast w op dst args
genCall (PrimTarget op@(MO_BSwap w)) [dst] args =
genCallSimpleCast w op dst args
-genCall (PrimTarget op@(MO_Pdep w)) [dst] args =
- genCallSimpleCast w op dst args
-genCall (PrimTarget op@(MO_Pext w)) [dst] args =
- genCallSimpleCast w op dst args
genCall (PrimTarget op@(MO_PopCnt w)) [dst] args =
genCallSimpleCast w op dst args
+{- Note [LLVM PDep/PExt intrinsics]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since x86 PDep/PExt instructions only exist for 32/64 bit widths
+we use the 32bit variant to compute the 8/16bit primops.
+To do so we extend/truncate the argument/result around the
+call.
+-}
+genCall (PrimTarget op@(MO_Pdep w)) [dst] args = do
+ cfg <- getConfig
+ if llvmCgBmiVersion cfg >= Just BMI2
+ then genCallMinimumTruncationCast W32 w op dst args
+ else genCallSimpleCast w op dst args
+genCall (PrimTarget op@(MO_Pext w)) [dst] args = do
+ cfg <- getConfig
+ if llvmCgBmiVersion cfg >= Just BMI2
+ then genCallMinimumTruncationCast W32 w op dst args
+ else genCallSimpleCast w op dst args
genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
addrVar <- exprToVarW addr
@@ -641,8 +654,15 @@ genCallExtract _ _ _ _ =
-- from i32 to i8 explicitly as LLVM is strict about types.
genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual]
-> LlvmM StmtData
-genCallSimpleCast specW op dst args = do
- let width = widthToLlvmInt specW
+genCallSimpleCast w = genCallMinimumTruncationCast w w
+
+-- Given the minimum machine bit-width to use and the logical bit-width of the
+-- value range, perform a type-cast truncation and extension before and after the
+-- specified operation, respectively.
+genCallMinimumTruncationCast :: Width -> Width -> CallishMachOp -> CmmFormal
+ -> [CmmActual] -> LlvmM StmtData
+genCallMinimumTruncationCast minW specW op dst args = do
+ let width = widthToLlvmInt $ max minW specW
argsW = const width <$> args
dstType = cmmToLlvmType $ localRegType dst
signage = cmmPrimOpRetValSignage op
@@ -945,9 +965,10 @@ cmmPrimOpFunctions mop = do
W256 -> fsLit "llvm.cttz.i256"
W512 -> fsLit "llvm.cttz.i512"
MO_Pdep w
+ -- See Note [LLVM PDep/PExt intrinsics]
| isBmi2Enabled -> case w of
- W8 -> fsLit "llvm.x86.bmi.pdep.8"
- W16 -> fsLit "llvm.x86.bmi.pdep.16"
+ W8 -> fsLit "llvm.x86.bmi.pdep.32"
+ W16 -> fsLit "llvm.x86.bmi.pdep.32"
W32 -> fsLit "llvm.x86.bmi.pdep.32"
W64 -> fsLit "llvm.x86.bmi.pdep.64"
W128 -> fsLit "llvm.x86.bmi.pdep.128"
@@ -963,8 +984,9 @@ cmmPrimOpFunctions mop = do
W512 -> fsLit "hs_pdep512"
MO_Pext w
| isBmi2Enabled -> case w of
- W8 -> fsLit "llvm.x86.bmi.pext.8"
- W16 -> fsLit "llvm.x86.bmi.pext.16"
+ -- See Note [LLVM PDep/PExt intrinsics]
+ W8 -> fsLit "llvm.x86.bmi.pext.32"
+ W16 -> fsLit "llvm.x86.bmi.pext.32"
W32 -> fsLit "llvm.x86.bmi.pext.32"
W64 -> fsLit "llvm.x86.bmi.pext.64"
W128 -> fsLit "llvm.x86.bmi.pext.128"
=====================================
testsuite/tests/llvm/should_run/T26065.hs
=====================================
@@ -0,0 +1,68 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Data.Char (toUpper)
+import GHC.Exts
+import GHC.Word
+import Numeric (showHex)
+
+pdep8 :: Word8 -> Word8 -> Word8
+pdep8 (W8# a) (W8# b) = W8# (wordToWord8# (pdep8# (word8ToWord# a) (word8ToWord# b)))
+{-# NOINLINE pdep8 #-}
+
+pdep16 :: Word16 -> Word16 -> Word16
+pdep16 (W16# a) (W16# b) = W16# (wordToWord16# (pdep16# (word16ToWord# a) (word16ToWord# b)))
+{-# NOINLINE pdep16 #-}
+
+pdep32 :: Word32 -> Word32 -> Word32
+pdep32 (W32# a) (W32# b) = W32# (wordToWord32# (pdep32# (word32ToWord# a) (word32ToWord# b)))
+{-# NOINLINE pdep32 #-}
+
+pdep64 :: Word64 -> Word64 -> Word64
+pdep64 (W64# a) (W64# b) = W64# (pdep64# a b)
+{-# NOINLINE pdep64 #-}
+
+pext8 :: Word8 -> Word8 -> Word8
+pext8 (W8# a) (W8# b) = W8# (wordToWord8# (pext8# (word8ToWord# a) (word8ToWord# b)))
+{-# NOINLINE pext8 #-}
+
+pext16 :: Word16 -> Word16 -> Word16
+pext16 (W16# a) (W16# b) = W16# (wordToWord16# (pext16# (word16ToWord# a) (word16ToWord# b)))
+{-# NOINLINE pext16 #-}
+
+pext32 :: Word32 -> Word32 -> Word32
+pext32 (W32# a) (W32# b) = W32# (wordToWord32# (pext32# (word32ToWord# a) (word32ToWord# b)))
+{-# NOINLINE pext32 #-}
+
+pext64 :: Word64 -> Word64 -> Word64
+pext64 (W64# a) (W64# b) = W64# (pext64# a b)
+{-# NOINLINE pext64 #-}
+
+valueSource :: Integral i => i
+valueSource = fromInteger 0xA7F7A7F7A7F7A7F7
+
+valueMask :: Integral i => i
+valueMask = fromInteger 0x5555555555555555
+
+printIntrinsicCall :: forall i. Integral i => String -> (i -> i -> i) -> IO ()
+printIntrinsicCall label f =
+ let op1 = valueSource
+ op2 = valueMask
+ pad s =
+ let hex :: Integral a => a -> String
+ hex = flip showHex ""
+ str = toUpper <$> hex s
+ len = length $ hex (maxBound :: Word64)
+ n = length str
+ in "0x" <> replicate (len - n) '0' <> str
+ in putStrLn $ unwords [ label, pad op1, pad op2, "=", pad (f op1 op2) ]
+
+main :: IO ()
+main = do
+ printIntrinsicCall "pdep8 " pdep8
+ printIntrinsicCall "pdep16" pdep16
+ printIntrinsicCall "pdep32" pdep32
+ printIntrinsicCall "pdep64" pdep64
+ printIntrinsicCall "pext8 " pext8
+ printIntrinsicCall "pext16" pext16
+ printIntrinsicCall "pext32" pext32
+ printIntrinsicCall "pext64" pext64
=====================================
testsuite/tests/llvm/should_run/T26065.stdout
=====================================
@@ -0,0 +1,8 @@
+pdep8 0x00000000000000F7 0x0000000000000055 = 0x0000000000000015
+pdep16 0x000000000000A7F7 0x0000000000005555 = 0x0000000000005515
+pdep32 0x00000000A7F7A7F7 0x0000000055555555 = 0x0000000044155515
+pdep64 0xA7F7A7F7A7F7A7F7 0x5555555555555555 = 0x4415551544155515
+pext8 0x00000000000000F7 0x0000000000000055 = 0x000000000000000F
+pext16 0x000000000000A7F7 0x0000000000005555 = 0x000000000000003F
+pext32 0x00000000A7F7A7F7 0x0000000055555555 = 0x0000000000003F3F
+pext64 0xA7F7A7F7A7F7A7F7 0x5555555555555555 = 0x000000003F3F3F3F
=====================================
testsuite/tests/llvm/should_run/all.T
=====================================
@@ -18,3 +18,8 @@ test('T22033', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_a
test('T25730', [req_c, unless(arch('x86_64'), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['T25730C.c'])
# T25730C.c contains Intel instrinsics, so only run this test on x86
test('T20645', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"]))], compile_and_run, [''])
+# T26065.c tests LLVM linking of Intel instrinsics, so only run this test on x86
+test('T26065', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"])),
+ unless((arch('x86_64') or arch('i386')) and have_cpu_feature('bmi2'),skip)],
+ compile_and_run, ['-mbmi2'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1db5d2a82682d4b6306bc5a3a1c8f9d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1db5d2a82682d4b6306bc5a3a1c8f9d…
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: Serialize wired-in names as external names when creating HIE files
by Marge Bot (＠marge-bot) 25 Aug '25
by Marge Bot (＠marge-bot) 25 Aug '25
25 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00
Serialize wired-in names as external names when creating HIE files
Note that the domain of de-serialized names stays the same.
Specifically, for known-key names, before `lookupKnownKeyName` was used,
while now this is handled by `lookupOrigNameCache` which captures the
same range provided that the OrigNameCache has been initialized with
`knownKeyNames` (which is the case by default).
(fixes #26238)
- - - - -
6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00
compiler: fix closure C type in SPT init code
This patch fixes the closure C type in SPT init code to StgClosure,
instead of the previously incorrect StgPtr. Having an incorrect C type
makes SPT init code not compatible with other foreign stub generation
logic, which may also emit their own extern declarations for the same
closure symbols and thus will clash with the incorrect prototypes in
SPT init code.
- - - - -
0e575bfe by Ben Gamari at 2025-08-25T10:29:17-04:00
Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd
- - - - -
b69a9c35 by Cheng Shao at 2025-08-25T10:29:17-04:00
wasm: ensure setKeepCAFs() is called in ghci
This patch is a critical bugfix for #26106, see comment and linked
issue for details.
- - - - -
12 changed files:
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/Types/Name/Cache.hs
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -17,7 +17,6 @@ where
import GHC.Prelude
-import GHC.Builtin.Utils
import GHC.Settings.Utils ( maybeRead )
import GHC.Settings.Config ( cProjectVersion )
import GHC.Utils.Binary
@@ -28,10 +27,8 @@ import GHC.Iface.Binary ( putAllTables )
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Unique
import GHC.Types.Unique.FM
import qualified GHC.Utils.Binary as Binary
-import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified Data.Array as A
@@ -290,6 +287,9 @@ fromHieName nc hie_name = do
case hie_name of
ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do
case lookupOrigNameCache cache mod occ of
+ -- Note that this may be a wired-in name (provided that the NameCache
+ -- was initialized with known-key names, which is always the case if you
+ -- use `newNameCache`).
Just name -> pure (cache, name)
Nothing -> do
uniq <- takeUniqFromNameCache nc
@@ -302,11 +302,6 @@ fromHieName nc hie_name = do
-- don't update the NameCache for local names
pure $ mkInternalName uniq occ span
- KnownKeyName u -> case lookupKnownKeyName u of
- Nothing -> pprPanic "fromHieName:unknown known-key unique"
- (ppr u)
- Just n -> pure n
-
-- ** Reading and writing `HieName`'s
putHieName :: WriteBinHandle -> HieName -> IO ()
@@ -316,9 +311,6 @@ putHieName bh (ExternalName mod occ span) = do
putHieName bh (LocalName occName span) = do
putByte bh 1
put_ bh (occName, BinSrcSpan span)
-putHieName bh (KnownKeyName uniq) = do
- putByte bh 2
- put_ bh $ unpkUnique uniq
getHieName :: ReadBinHandle -> IO HieName
getHieName bh = do
@@ -330,7 +322,4 @@ getHieName bh = do
1 -> do
(occ, span) <- get bh
return $ LocalName occ $ unBinSrcSpan span
- 2 -> do
- (c,i) <- get bh
- return $ KnownKeyName $ mkUnique c i
_ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag"
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -19,14 +19,12 @@ import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
import GHC.Data.FastString
-import GHC.Builtin.Utils
import GHC.Iface.Type
import GHC.Unit.Module ( ModuleName, Module )
import GHC.Types.Name
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Types.SrcLoc
import GHC.Types.Avail
-import GHC.Types.Unique
import qualified GHC.Utils.Outputable as O ( (<>) )
import GHC.Utils.Panic
import GHC.Core.ConLike ( ConLike(..) )
@@ -766,7 +764,6 @@ instance Binary TyVarScope where
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
- | KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
@@ -774,34 +771,28 @@ instance Ord HieName where
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
- compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
- -- Not actually non deterministic as it is a KnownKey
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
- compare LocalName{} _ = LT
- compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
- ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
hieNameOcc :: HieName -> OccName
hieNameOcc (ExternalName _ occ _) = occ
hieNameOcc (LocalName occ _) = occ
-hieNameOcc (KnownKeyName u) =
- case lookupKnownKeyName u of
- Just n -> nameOccName n
- Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
- (ppr u)
toHieName :: Name -> HieName
-toHieName name
- | isKnownKeyName name = KnownKeyName (nameUnique name)
- | isExternalName name = ExternalName (nameModule name)
- (nameOccName name)
- (removeBufSpan $ nameSrcSpan name)
- | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
+toHieName name =
+ case nameModule_maybe name of
+ Nothing -> LocalName occName span
+ Just m -> ExternalName m occName span
+ where
+ occName :: OccName
+ occName = nameOccName name
+
+ span :: SrcSpan
+ span = removeBufSpan $ nameSrcSpan name
{- Note [Capture Entity Information]
=====================================
compiler/GHC/Iface/Tidy/StaticPtrTable.hs
=====================================
@@ -17,18 +17,18 @@
-- > static void hs_hpc_init_Main(void) {
-- >
-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
--- > extern StgPtr Main_r2wb_closure;
+-- > extern StgClosure Main_r2wb_closure;
-- > hs_spt_insert(k0, &Main_r2wb_closure);
-- >
-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
--- > extern StgPtr Main_r2wc_closure;
+-- > extern StgClosure Main_r2wc_closure;
-- > hs_spt_insert(k1, &Main_r2wc_closure);
-- >
-- > }
--
-- where the constants are fingerprints produced from the static forms.
--
--- The linker must find the definitions matching the @extern StgPtr <name>@
+-- The linker must find the definitions matching the @extern StgClosure <name>@
-- declarations. For this to work, the identifiers of static pointers need to be
-- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'.
--
@@ -263,7 +263,7 @@ sptModuleInitCode platform this_mod entries
-- CLabel. Regardless, MayHaveCafRefs/NoCafRefs wouldn't make
-- any difference here, they would pretty-print to the same
-- foreign stub content.
- $$ text "extern StgPtr "
+ $$ text "extern StgClosure "
<> (pprCLabel platform $ mkClosureLabel n MayHaveCafRefs) <> semi
$$ text "hs_spt_insert" <> parens
(hcat $ punctuate comma
=====================================
compiler/GHC/Types/Name/Cache.hs
=====================================
@@ -101,9 +101,14 @@ OrigNameCache at all? Good question; after all,
3) Loading of interface files encodes names via Uniques, as detailed in
Note [Symbol table representation of names] in GHC.Iface.Binary
-It turns out that we end up looking up built-in syntax in the cache when we
-generate Haddock documentation. E.g. if we don't find tuple data constructors
-there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs)
+
+However note that:
+ 1) It turns out that we end up looking up built-in syntax in the cache when
+ we generate Haddock documentation. E.g. if we don't find tuple data
+ constructors there, hyperlinks won't work as expected. Test case:
+ haddockHtmlTest (Bug923.hs)
+ 2) HIE de-serialization relies on wired-in names, including built-in syntax,
+ being present in the OrigNameCache.
-}
-- | The NameCache makes sure that there is just one Unique assigned for
=====================================
rts/PrimOps.cmm
=====================================
@@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
gcptr trec, outer, arg;
trec = StgTSO_trec(CurrentTSO);
- 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);
+ 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();
}
}
@@ -1464,26 +1453,21 @@ retry_pop_stack:
outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
- // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_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");
if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
- // 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;
+ // Retry in the first branch: try the alternative
+ ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
+ StgTSO_trec(CurrentTSO) = trec;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
jump stg_ap_v_fast [R1];
} else {
- // Retry in the rhs code: propagate the retry
+ // Retry in the alternative code: propagate the retry
+ StgTSO_trec(CurrentTSO) = outer;
Sp = Sp + SIZEOF_StgCatchRetryFrame;
goto retry_pop_stack;
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
}
case CATCH_STM_FRAME:
- // CATCH_STM frame within an atomically block: abort the
+ case CATCH_RETRY_FRAME:
+ // CATCH frames within an atomically block: abort the
// inner transaction and continue. Eventually we will
// hit the outer transaction that will get frozen (see
// above).
@@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
{
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = trec -> enclosing_trec;
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
+ debugTraceCap(DEBUG_stm, cap,
+ "found atomically block delivering async exception");
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,30 +1505,3 @@ 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/lib/stm/T26028.hs deleted
=====================================
@@ -1,23 +0,0 @@
-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 deleted
=====================================
@@ -1 +0,0 @@
-"terminates"
=====================================
testsuite/tests/lib/stm/all.T deleted
=====================================
@@ -1 +0,0 @@
-test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -229,10 +229,7 @@ writeInterfaceFile filename iface = do
return ()
freshNameCache :: IO NameCache
-freshNameCache =
- initNameCache
- 'a' -- ??
- []
+freshNameCache = newNameCache
-- | Read a Haddock (@.haddock@) interface file. Return either an
-- 'InterfaceFile' or an error message.
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1105,6 +1105,20 @@ class DyLD {
if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) {
this.rts_init();
delete this.rts_init;
+
+ // At this point the RTS symbols in linear memory are fixed
+ // and constructors are run, especially the one in JSFFI.c
+ // that does GHC RTS initialization for any code that links
+ // JSFFI.o. Luckily no Haskell computation or gc has taken
+ // place yet, so we must set keepCAFs=1 right now! Otherwise,
+ // any BCO created by later TH splice or ghci expression may
+ // refer to any CAF that's not reachable from GC roots (here
+ // our only entry point is defaultServer) and the CAF could
+ // have been GC'ed! (#26106)
+ //
+ // We call it here instead of in RTS C code, since we only
+ // want keepCAFs=1 for ghci, not user code.
+ this.exportFuncs.setKeepCAFs();
}
init();
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5431ced6b0693ba980140b15207e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5431ced6b0693ba980140b15207e3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
25 Aug '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
34fc50c1 by Ben Gamari at 2025-08-11T13:36:25-04:00
Kill IOPort#
This type is unnecessary, having been superceded by `MVar` and a rework
of WinIO's blocking logic.
See #20947.
See https://github.com/haskell/core-libraries-committee/issues/213.
- - - - -
56b32c5a by sheaf at 2025-08-12T10:00:19-04:00
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
For example, we now are properly able to prove the subtyping relationship
((∀ a. a->a) -> Int) -> Bool <= β[tau] Bool
for an unfilled metavariable β. In this case (with an AppTy on the right),
we used to fall back to unification. No longer: now, given that the LHS
is a FunTy and that the RHS is a deep rho type (does not need any instantiation),
we try to make the RHS into a FunTy, viz.
β := (->) γ
We can then continue using covariance & contravariance of the function
arrow, which allows us to prove the subtyping relationship, instead of
trying to unify which would cause us to error out with:
Couldn't match expected type ‘β’ with actual type ‘(->) ((∀ a. a -> a) -> Int)
See Note [FunTy vs non-FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify.
The other main improvement in this patch concerns type inference.
The main subsumption logic happens (before & after this patch) in
GHC.Tc.Gen.App.checkResultTy. However, before this patch, all of the
DeepSubsumption logic only kicked in in 'check' mode, not in 'infer' mode.
This patch adds deep instantiation in the 'infer' mode of checkResultTy
when we are doing deep subsumption, which allows us to accept programs
such as:
f :: Int -> (forall a. a->a)
g :: Int -> Bool -> Bool
test1 b =
case b of
True -> f
False -> g
test2 b =
case b of
True -> g
False -> f
See Note [Deeply instantiate in checkResultTy when inferring].
Finally, we add representation-polymorphism checks to ensure that the
lambda abstractions we introduce when doing subsumption obey the
representation polymorphism invariants of Note [Representation polymorphism invariants]
in GHC.Core. See Note [FunTy vs FunTy case in tc_sub_type_deep].
This is accompanied by a courtesy change to `(<.>) :: HsWrapper -> HsWrapper -> HsWrapper`,
adding the equation:
WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2)
This is useful because mkWpFun does not introduce an eta-expansion when
both of the argument & result wrappers are casts; so this change allows
us to avoid introducing lambda abstractions when casts suffice.
Fixes #26225
- - - - -
d175aff8 by Sylvain Henry at 2025-08-12T10:01:31-04:00
Add regression test for #18619
- - - - -
a3983a26 by Sylvain Henry at 2025-08-12T10:02:20-04:00
RTS: remove some TSAN annotations (#20464)
Use RELAXED_LOAD_ALWAYS macro instead.
- - - - -
0434af81 by Ben Gamari at 2025-08-12T10:03:02-04:00
Bump time submodule to 1.15
Also required bumps of Cabal, directory, and hpc.
- - - - -
62899117 by Florian Ragwitz at 2025-08-13T21:01:34-04:00
Extend record-selector usage ticking to all binds using a record field
This extends the previous handling of ticking for RecordWildCards and
NamedFieldPuns to all var bindings that involve record selectors.
Note that certain patterns such as `Foo{foo = 42}` will currently not tick the
`foo` selector, as ticking is triggered by `HsVar`s.
Closes #26191.
- - - - -
b37b3af7 by Florian Ragwitz at 2025-08-13T21:01:34-04:00
Add release notes for 9.16.1 and move description of latest HPC changes there.
- - - - -
a5e4b7d9 by Ben Gamari at 2025-08-13T21:02:18-04:00
rts: Clarify rationale for undefined atomic wrappers
Since c06e3f46d24ef69f3a3d794f5f604cb8c2a40cbc the RTS has declared
various atomic operation wrappers defined by ghc-internal as undefined.
While the rationale for this isn't clear from the commit message, I
believe that this is necessary due to the unregisterised backend.
Specifically, the code generator will reference these symbols when
compiling RTS Cmm sources.
- - - - -
50842f83 by Andreas Klebinger at 2025-08-13T21:03:01-04:00
Make unexpected LLVM versions a warning rather than an error.
Typically a newer LLVM version *will* work so erroring out if
a user uses a newer LLVM version is too aggressive.
Fixes #25915
- - - - -
c91e2650 by fendor at 2025-08-13T21:03:43-04:00
Store `StackTrace` and `StackSnapshot` in `Backtraces`
Instead of decoding the stack traces when collecting the `Backtraces`,
defer this decoding until actually showing the `Backtraces`.
This allows users to customise how `Backtraces` are displayed by
using a custom implementation of `displayExceptionWithInfo`, overwriting
the default implementation for `Backtraces` (`displayBacktraces`).
- - - - -
dee28cdd by fendor at 2025-08-13T21:03:43-04:00
Allow users to customise the collection of exception annotations
Add a global `CollectExceptionAnnotationMechanism` which determines how
`ExceptionAnnotation`s are collected upon throwing an `Exception`.
This API is exposed via `ghc-experimental`.
By overriding how we collect `Backtraces`, we can control how the
`Backtraces` are displayed to the user by newtyping `Backtraces` and
giving a different instance for `ExceptionAnnotation`.
A concrete use-case for this feature is allowing us to experiment with
alternative stack decoders, without having to modify `base`, which take
additional information from the stack frames.
This commit does not modify how `Backtraces` are currently
collected or displayed.
- - - - -
66024722 by fendor at 2025-08-13T21:03:43-04:00
Expose Backtraces internals from ghc-experimental
Additionally, expose the same API `base:Control.Exception.Backtrace`
to make it easier to use as a drop-in replacement.
- - - - -
a766286f by Reed Mullanix at 2025-08-13T21:04:36-04:00
ghc-internal: Fix naturalAndNot for NB/NS case
When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the
result:
```
>>> naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
0
```
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
- - - - -
3506fa7d by Simon Hengel at 2025-08-13T21:05:18-04:00
Report -pgms as a deprecated flag
(instead of reporting an unspecific warning)
Before:
on the commandline: warning:
Object splitting was removed in GHC 8.8
After:
on the commandline: warning: [GHC-53692] [-Wdeprecated-flags]
-pgms is deprecated: Object splitting was removed in GHC 8.8
- - - - -
51c701fe by Zubin Duggal at 2025-08-13T21:06:00-04:00
testsuite: Be more permissive when filtering out GNU_PROPERTY_TYPE linker warnings
The warning text is slightly different with ld.bfd.
Fixes #26249
- - - - -
dfe6f464 by Simon Hengel at 2025-08-13T21:06:43-04:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
a8b2fbae by Teo Camarasu at 2025-08-13T21:07:24-04:00
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
- - - - -
4021181e by Teo Camarasu at 2025-08-13T21:07:24-04:00
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
- - - - -
1107af89 by Oleg Grenrus at 2025-08-13T21:08:06-04:00
Allow defining HasField instances for naughty fields
Resolves #26295
... as HasField solver doesn't solve for fields with "naughty"
selectors, we could as well allow defining HasField instances for these
fields.
- - - - -
020e7587 by Sylvain Henry at 2025-08-13T21:09:00-04:00
Fix Data.List unqualified import warning
- - - - -
fd811ded by Simon Peyton Jones at 2025-08-14T17:56:47-04:00
Make injecting implicit bindings into its own pass
Previously we were injecting "impliicit bindings" (data constructor
worker and wrappers etc)
- both at the end of CoreTidy,
- and at the start of CorePrep
This is unpleasant and confusing. This patch puts it it its own pass,
addImplicitBinds, which runs between the two.
The function `GHC.CoreToStg.AddImplicitBinds.addImplicitBinds` now takes /all/
TyCons, not just the ones for algebraic data types. That change ripples
through to
- corePrepPgm
- doCodeGen
- byteCodeGen
All take [TyCon] which includes all TyCons
- - - - -
9bd7fcc5 by Simon Peyton Jones at 2025-08-14T17:56:47-04:00
Implement unary classes
The big change is described exhaustively in
Note [Unary class magic] in GHC.Core.TyCon
Other changes
* We never unbox class dictionaries in worker/wrapper. This has been true for some
time now, but the logic is now centralised in functions in
GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg`
See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils.
* Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels.
I can't remember if I actually changed any behaviour here, but if so it's
only in a corner cases.
* Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning
True for (##).
* Remove redundant Role argument to `liftCoSubstWithEx`. It was always
Representational.
* I refactored evidence generation in the constraint solver:
* Made GHC.Tc.Types.Evidence contain better abstactions for evidence
generation.
* I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents
elsewhere. It wasn't paying its way.
* Made evidence for implicit parameters go via a proper abstraction.
* Fix inlineBoringOk; see (IB6) in Note [inlineBoringOk]
This fixes a slowdown in `countdownEffectfulDynLocal`
in the `effectful` library.
Smaller things
* Rename `isDataTyCon` to `isBoxedDataTyCon`.
* GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role,
so I baked that into the function and removed the argument.
* Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling
`not isNewTyCon` at the call sites; more explicit.
* Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its
behaviour
* Moved `decomposeIPPred` to GHC.Core.Predicate
Compile time performance changes:
geo. mean +0.1%
minimum -6.8%
maximum +14.4%
The +14% one is in T21839c, where it seems that a bit more inlining
is taking place. That seems acceptable; and the average change is small
Metric Decrease:
LargeRecord
T12227
T12707
T16577
T21839r
T5642
Metric Increase:
T15164
T21839c
T3294
T5321FD
T5321Fun
WWRec
- - - - -
b4075d71 by Simon Peyton Jones at 2025-08-14T17:56:47-04:00
Slight improvement to pre/postInlineUnconditionally
Avoids an extra simplifier iteration
- - - - -
9e443596 by Simon Peyton Jones at 2025-08-14T17:56:47-04:00
Fix a long-standing assertion error in normSplitTyConApp_maybe
- - - - -
91310ad0 by Simon Peyton Jones at 2025-08-14T17:56:47-04:00
Add comment to coercion optimiser
- - - - -
5b841d82 by Teo Camarasu at 2025-08-14T17:57:56-04:00
template-haskell: move some identifiers from ghc-internal to template-haskell
These identifiers are not used internally by the compiler. Therefore we
have no reason for them to be in ghc-internal.
By moving them to template-haskell, we benefit from it being easier to
change them and we avoid having to build them in stage0.
Resolves #26048
- - - - -
33e2c7e5 by Teo Camarasu at 2025-08-14T17:57:56-04:00
template-haskell: transfer $infix note to public module
This Haddock note should be in the public facing module
- - - - -
2a411fc4 by Sylvain Henry at 2025-08-14T17:59:09-04:00
JS: export HEAP8 symbol (#26290)
Newer Emscripten requires this.
- - - - -
248f78ca by Ben Gamari at 2025-08-14T17:59:51-04:00
users-guide: Drop the THREAD_RUNNABLE event
As of f361281c89fbce42865d8b8b27b0957205366186 it is no longer emitted.
- - - - -
706d33e3 by Recursion Ninja at 2025-08-15T04:12:12-04:00
Resolving issues #20645 and #26109
Correctly sign extending and casting smaller bit width types for LLVM operations:
- bitReverse8#
- bitReverse16#
- bitReverse32#
- byteSwap16#
- byteSwap32#
- pdep8#
- pdep16#
- pext8#
- pext16#
- - - - -
1cdc6f46 by Cheng Shao at 2025-08-15T04:12:56-04:00
hadrian: enforce have_llvm=False for wasm32/js
This patch fixes hadrian to always pass have_llvm=False to the
testsuite driver for wasm32/js targets. These targets don't really
support the LLVM backend, and the optllvm test way doesn't work. We
used to special-case wasm32/js to avoid auto-adding optllvm way in
testsuite/config/ghc, but this is still problematic if someone writes
a new LLVM-related test and uses something like when(have_llvm(),
extra_ways(["optllvm"])). So better just enforce have_llvm=False for
these targets here.
- - - - -
ca03226d by Ben Gamari at 2025-08-18T13:43:20+00:00
configure: Allow use of LLVM 20
- - - - -
783cd7d6 by Cheng Shao at 2025-08-18T20:13:14-04:00
compiler: use `UniqMap` instead of `Map` for `BCEnv` in bytecode compiler
The bytecode compiler maintains a `BCEnv` which was previously `Map Id
StackDepth`. Given `Id` is `Uniquable`, we might as well use `UniqMap`
here as a more efficient data structure, hence this patch.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
58e46da9 by fendor at 2025-08-18T20:13:56-04:00
rts: Strip lower three bits when hashing Word instead of lower eight bits
- - - - -
45dbfa23 by Cheng Shao at 2025-08-18T20:14:37-04:00
libffi: update to 3.5.2
Bumps libffi submodule.
- - - - -
54be78ef by Ben Gamari at 2025-08-19T16:28:05-04:00
testsuite: Fix T20006b
This test is supposed to fail for non-threaded ways yet it
was previously marked as only failing in `normal`.
Fix this.
- - - - -
f4bac607 by Simon Peyton Jones at 2025-08-19T16:28:47-04:00
Take yet more care with reporting redundant constraints
This small patch fixes #25992, which relates to reporting redundant
constraints on default-method declarations.
See (TRC5) in Note [Tracking redundant constraints]
- - - - -
ab130fec by fendor at 2025-08-19T16:29:29-04:00
Bump dependencies of hadrian-bootstrap-gen to use GHC 9.6.7
- - - - -
6d02ac6f by fendor at 2025-08-19T16:29:29-04:00
Bump required GHC version for test-bootstrap jobs to 9.10.1
Include test-bootstrap job for GHC 9.12.2.
Update hadrian bootstrap plans use GHC 9.10 and 9.12
Remove older GHC bootstrap configurations.
We require at least GHC 9.10.1 to build GHC.
Adds plans for:
* 9.10.1
* 9.10.2
* 9.12.1
* 9.12.2
- - - - -
9e857171 by Brandon Chinn at 2025-08-20T11:47:46-04:00
Don't warn unused-imports with used generated imports
Fixes #21730
* The old notion of "implicit" import has been renamed to "generated". See Note [Generated imports] in GHC.Hs.ImpExp.
* ImportMap now keeps track of generated and user-written imports separately. This avoids the fake SrcSpan we used to give the implicit Prelude import, and the hack that went with it.
* -ddump-minimal-imports now considers generated imports (but still only
warns on + prints user-written imports)
* bestImport considers generated imports to take priority over user-written imports.
- - - - -
9fb3bad4 by Ben Gamari at 2025-08-20T11:48:31-04:00
mailmap: Use ben(a)well-typed.com more liberally
Nearly all of this work was done while working for Well-Typed.
- - - - -
774fec37 by Ben Gamari at 2025-08-20T11:49:15-04:00
Add primop to annotate the call stack with arbitrary data
We introduce a new primop `annotateStack#` which allows us to push
arbitrary data onto the call-stack.
This allows us to extract the data later when decoding the stack, for
example when an exception is thrown, showing more information to the
user without having to annotate the full call-stack with `HasCallStack`
constraints.
A new stack frame value is introduced `AnnFrame`, which consists of
nothing but a generic payload.
The primop has a small wrapper API that allows users to annotate their
call-stack in programs.
There is a pure API and an IO-based one. The former is a little bit
dubious, as it affects the evaluation of a program, so use with care.
The latter is "safe", as it doesn't change the evaluation of the
program.
The stack annotation mechanism is similarly implemented to the
`ExceptionAnnotation` and `Exception`, there is a typeclass to indicate
something can be pushed onto the call-stack and all values are wrapped
in the existential `SomeStackAnnotation`, which recover the type of the
annotation payload.
There is currently no builtin way to show the stack annotations when
`Backtraces` are displayed (i.e., when showing stack traces to the user),
which we will address in a follow-up MR.
-------------------------
Metric Increase:
ghc_experimental_so
-------------------------
We increase the size of the package, so this is not unreasonable.
Co-Authored-By: fendor <fendor(a)posteo.de>
Co-Authored-By: Ben Gamari <bgamari.foss(a)gmail.com>
- - - - -
fdfa3892 by Ben Gamari at 2025-08-20T11:49:57-04:00
testsuite: Add regression test for #24606
- - - - -
39b2e382 by Cheng Shao at 2025-08-20T11:50:40-04:00
compiler: only use `Name` instead of `Id` in `SptEntry`
As a part of #26298, this patch refactors `SptEntry` to only carry a
`Name` instead of `Id`: we do not care about extra information like
caffyness or type at all in any static pointer related codegen logic.
This is necessary to make `SptEntry` serializable, as a part of the
grand plan of serializable bytecode.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
276f8ea8 by Vekhir -- at 2025-08-20T11:51:35-04:00
Bump Cabal dependency
- - - - -
0b9c7437 by Zubin Duggal at 2025-08-20T11:52:18-04:00
ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and bootstrap compiler on FreeBSD to 9.10.1
Also refactor fetch_ghc logic in ci.sh, renaming the GHC_VERSION enviorment configuration variable to FETCH_GHC_VERSION,
making it clear that it is intended for use on platforms like Windows and FreeBSD where we don't want to use the GHC
excecutable from the platform environment and instead need to download and install GHC-$FETCH_GHC_VERSION from a release
bindist.
Fixes #26296
- - - - -
b2914797 by Cheng Shao at 2025-08-20T11:53:00-04:00
driver: use UniqSet for hiddenModules in DynFlags/FinderOpts
This patch replaces Set ModuleName with UniqSet ModuleName in
DynFlags.hiddenModules and FinderOpts.finder_hiddenModules for
improved efficiency.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
0335d899 by Cheng Shao at 2025-08-20T11:53:00-04:00
driver: use UniqMap ModuleName in the finder
This patch replaces Map ModuleName with UniqMap ModuleName in the
finder for improved efficiency.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
91f4faaa by Cheng Shao at 2025-08-20T11:53:43-04:00
configure: check python3 version and require minimal 3.7
Since !9515, the testsuite driver requires python3 version to be at
least 3.7, though this has never been checked by configure logic. This
patch implements the version check. Fixes #23234.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
df4ee9b4 by Cheng Shao at 2025-08-20T11:54:25-04:00
compiler: use zero cost coerce in GHC.CmmToAsm.CFG.loopInfo
This patch refactors GHC.CmmToAsm.CFG.loopInfo to use zero cost coerce
and thus addresses the TODO. For coerce to work, constructors of
Label/LabelMap/LabelSet from GHC.Cmm.Dataflow.Label are exposed,
though I believe it's a worthy tradeoff to avoid unnecessary runtime
cost without using unsafeCoerce, since the latter could be a landmine
for future refactoring.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
ccda188d by Simon Peyton Jones at 2025-08-20T11:55:07-04:00
Start with empty inerts in shortcut solving
When short-cut solving we were starting with an inert set that had
unsolved Wanteds. This caused an infinite loop (#26314), because a
typechecker plugin kept being given that unsolved Wanted.
It's better just to start with an empty inert set
- - - - -
c8882ed7 by Ben Gamari at 2025-08-20T11:55:49-04:00
configure: Bump minimal bootstrap GHC version to 9.8
- - - - -
f0a19d74 by fendor at 2025-08-20T19:55:00-04:00
Remove deprecated functions from the ghci package
- - - - -
ebeb991b by fendor at 2025-08-20T19:55:00-04:00
base: Remove unstable heap representation details from GHC.Exts
- - - - -
e368e247 by Rodrigo Mesquita at 2025-08-20T19:55:42-04:00
bytecode: Use 32bits for breakpoint index
Fixes #26325
- - - - -
42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00
Serialize wired-in names as external names when creating HIE files
Note that the domain of de-serialized names stays the same.
Specifically, for known-key names, before `lookupKnownKeyName` was used,
while now this is handled by `lookupOrigNameCache` which captures the
same range provided that the OrigNameCache has been initialized with
`knownKeyNames` (which is the case by default).
(fixes #26238)
- - - - -
6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00
compiler: fix closure C type in SPT init code
This patch fixes the closure C type in SPT init code to StgClosure,
instead of the previously incorrect StgPtr. Having an incorrect C type
makes SPT init code not compatible with other foreign stub generation
logic, which may also emit their own extern declarations for the same
closure symbols and thus will clash with the incorrect prototypes in
SPT init code.
- - - - -
c4b833d2 by Apoorv Ingle at 2025-08-25T08:57:25-05:00
This commit:
- Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr`
Calls `setInGeneratedCode` everytime the typechecker goes over an `XExpr`
- Kills `VACtxt` (and its associated VAExpansion and VACall) datatype, it is subsumed by simply a SrcSpan.
- Kills the function `addHeadCtxt` as it is now mearly setting a location
- The function `tcValArgs` does its own argument number management
- Makes `splitHsApps` not look through `XExpr`
- `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr`
- Removes location information from `OrigPat` payload
- Removes special case of tcBody from `tcLambdaMatches`
- Removes special case of `dsExpr` for `ExpandedThingTc`
- Moves `setQLInstLevel` inside `tcInstFun`
- Rename `HsThingRn` to `SrcCodeCtxt`
- Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack`
- Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin`
- Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression
- Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax
- Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo`
- Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr`
- Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span`
Notes added [Error Context Stack]
Notes updated Note [Expanding HsDo with XXExprGhcRn]
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
439 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .mailmap
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/PrimOps/Ids.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Class.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg.hs
- + compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/StaticPtr.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- − compiler/GHC/Tc/Types/EvTerm.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/TyThing.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Utils/Error.hs
- compiler/ghc.cabal.in
- configure.ac
- − docs/users_guide/9.14.1-notes.rst
- + docs/users_guide/9.16.1-notes.rst
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/release-notes.rst
- ghc/GHCi/UI.hs
- ghc/ghc-bin.cabal.in
- hadrian/bootstrap/generate_bootstrap_plans
- hadrian/bootstrap/hadrian-bootstrap-gen.cabal
- hadrian/bootstrap/plan-9_10_1.json
- hadrian/bootstrap/plan-9_6_5.json → hadrian/bootstrap/plan-9_10_2.json
- hadrian/bootstrap/plan-9_6_6.json → hadrian/bootstrap/plan-9_12_1.json
- hadrian/bootstrap/plan-9_6_4.json → hadrian/bootstrap/plan-9_12_2.json
- − hadrian/bootstrap/plan-9_6_1.json
- − hadrian/bootstrap/plan-9_6_2.json
- − hadrian/bootstrap/plan-9_6_3.json
- − hadrian/bootstrap/plan-9_8_1.json
- − hadrian/bootstrap/plan-9_8_2.json
- hadrian/bootstrap/plan-bootstrap-9_10_1.json
- hadrian/bootstrap/plan-bootstrap-9_6_5.json → hadrian/bootstrap/plan-bootstrap-9_10_2.json
- hadrian/bootstrap/plan-bootstrap-9_6_6.json → hadrian/bootstrap/plan-bootstrap-9_12_1.json
- hadrian/bootstrap/plan-bootstrap-9_8_1.json → hadrian/bootstrap/plan-bootstrap-9_12_2.json
- − hadrian/bootstrap/plan-bootstrap-9_6_1.json
- − hadrian/bootstrap/plan-bootstrap-9_6_2.json
- − hadrian/bootstrap/plan-bootstrap-9_6_3.json
- − hadrian/bootstrap/plan-bootstrap-9_6_4.json
- − hadrian/bootstrap/plan-bootstrap-9_8_2.json
- hadrian/bootstrap/src/Main.hs
- hadrian/hadrian.cabal
- hadrian/src/Settings/Builders/RunTest.hs
- libffi-tarballs
- libraries/Cabal
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/GHC/Exts.hs
- − libraries/base/src/GHC/IOPort.hs
- libraries/directory
- libraries/ghc-bignum/changelog.md
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/GHC/Exception/Backtrace/Experimental.hs
- + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- + libraries/ghc-heap/tests/stack-annotation/Makefile
- + libraries/ghc-heap/tests/stack-annotation/TestUtils.hs
- + libraries/ghc-heap/tests/stack-annotation/all.T
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout
- libraries/ghc-internal/cbits/pdep.c
- libraries/ghc-internal/cbits/pext.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs
- libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc
- libraries/ghc-internal/src/GHC/Internal/Event/Windows/Thread.hs
- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc
- − libraries/ghc-internal/src/GHC/Internal/IOPort.hs
- libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- + libraries/ghc-internal/tests/Makefile
- + libraries/ghc-internal/tests/all.T
- + libraries/ghc-internal/tests/backtraces/Makefile
- + libraries/ghc-internal/tests/backtraces/T14532a.hs
- + libraries/ghc-internal/tests/backtraces/T14532a.stdout
- + libraries/ghc-internal/tests/backtraces/T14532b.hs
- + libraries/ghc-internal/tests/backtraces/T14532b.stdout
- + libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-prim/changelog.md
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- libraries/hpc
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/tests/all.T
- libraries/time
- libraries/unix
- m4/find_python.m4
- rts/ClosureFlags.c
- rts/Disassembler.c
- rts/Hash.c
- rts/Interpreter.c
- rts/LdvProfile.c
- rts/Messages.c
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RetainerProfile.c
- rts/RtsSymbols.c
- rts/StgMiscClosures.cmm
- rts/TraverseHeap.c
- rts/Updates.h
- rts/external-symbols.list.in
- rts/include/rts/storage/ClosureTypes.h
- rts/include/rts/storage/Closures.h
- rts/include/stg/MiscClosures.h
- rts/include/stg/SMP.h
- rts/js/mem.js
- rts/js/profiling.js
- rts/posix/ticker/Pthread.c
- rts/posix/ticker/TimerFd.c
- rts/rts.cabal
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- rts/sm/Sanity.c
- rts/sm/Scav.c
- rts/win32/AsyncWinIO.c
- rts/win32/libHSghc-internal.def
- testsuite/config/ghc
- testsuite/driver/testlib.py
- testsuite/tests/arrows/should_compile/T21301.stderr
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/corelint/LintEtaExpand.stderr
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
- testsuite/tests/deSugar/should_run/T20024.stderr
- testsuite/tests/deSugar/should_run/dsrun005.stderr
- testsuite/tests/deSugar/should_run/dsrun007.stderr
- testsuite/tests/deSugar/should_run/dsrun008.stderr
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/deriving/should_run/T9576.stderr
- testsuite/tests/dmdanal/should_compile/T16029.stdout
- testsuite/tests/dmdanal/sigs/T21119.stderr
- testsuite/tests/dmdanal/sigs/T21888.stderr
- testsuite/tests/gadt/T12468.stderr
- testsuite/tests/ghc-e/should_fail/T24172.stderr
- testsuite/tests/ghci.debugger/scripts/break011.stdout
- testsuite/tests/ghci.debugger/scripts/break024.stdout
- testsuite/tests/ghci/scripts/Defer02.stderr
- testsuite/tests/ghci/scripts/T15325.stderr
- testsuite/tests/ghci/scripts/T8353.stderr
- testsuite/tests/ghci/scripts/ghci038.stdout
- testsuite/tests/hpc/recsel/recsel.hs
- testsuite/tests/hpc/recsel/recsel.stdout
- testsuite/tests/indexed-types/should_compile/T2238.hs
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/llvm/should_run/T20645.hs
- + testsuite/tests/llvm/should_run/T20645.stdout
- testsuite/tests/llvm/should_run/all.T
- − testsuite/tests/module/T21752.stderr
- testsuite/tests/module/mod150.stderr
- testsuite/tests/module/mod151.stderr
- testsuite/tests/module/mod152.stderr
- testsuite/tests/module/mod153.stderr
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/numeric/should_compile/T23907.stderr
- + testsuite/tests/numeric/should_run/T18619.hs
- + testsuite/tests/numeric/should_run/T18619.stderr
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr
- + testsuite/tests/overloadedrecflds/should_run/T26295.hs
- + testsuite/tests/overloadedrecflds/should_run/T26295.stdout
- testsuite/tests/overloadedrecflds/should_run/all.T
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T19082.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/partial-sigs/should_compile/T10403.stderr
- testsuite/tests/partial-sigs/should_fail/T10615.stderr
- testsuite/tests/patsyn/should_run/ghci.stderr
- testsuite/tests/perf/compiler/hard_hole_fits.stderr
- testsuite/tests/plugins/Makefile
- + testsuite/tests/plugins/T21730-plugin/Makefile
- + testsuite/tests/plugins/T21730-plugin/Setup.hs
- + testsuite/tests/plugins/T21730-plugin/T21730-plugin.cabal
- + testsuite/tests/plugins/T21730-plugin/T21730_Plugin.hs
- + testsuite/tests/plugins/T21730.hs
- testsuite/tests/plugins/all.T
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/primops/should_run/UnliftedIOPort.hs
- testsuite/tests/primops/should_run/all.T
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/quasiquotation/T4491/test.T
- testsuite/tests/quotes/LiftErrMsg.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/quotes/LiftErrMsgTyped.stderr
- testsuite/tests/rename/should_compile/T22513d.stderr
- testsuite/tests/rename/should_compile/T22513e.stderr
- testsuite/tests/rename/should_compile/T22513f.stderr
- testsuite/tests/rename/should_compile/T22513g.stderr
- testsuite/tests/rename/should_compile/T22513h.stderr
- testsuite/tests/rename/should_compile/T22513i.stderr
- testsuite/tests/rename/should_compile/rn039.ghc.stderr
- testsuite/tests/rename/should_fail/T15487.stderr
- testsuite/tests/rename/should_fail/T18740a.stderr
- testsuite/tests/rename/should_fail/rnfail044.stderr
- + testsuite/tests/rep-poly/NoEtaRequired.hs
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/rep-poly/T21906.stderr
- testsuite/tests/rep-poly/all.T
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/rts/flags/all.T
- testsuite/tests/safeHaskell/flags/SafeFlags17.stderr
- testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr
- testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T17366.stderr
- testsuite/tests/simplCore/should_compile/T17966.stderr
- testsuite/tests/simplCore/should_compile/T22309.stderr
- testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr
- testsuite/tests/simplCore/should_compile/T23307.stderr
- testsuite/tests/simplCore/should_compile/T23307a.stderr
- + testsuite/tests/simplCore/should_compile/T24606.hs
- testsuite/tests/simplCore/should_compile/T25389.stderr
- testsuite/tests/simplCore/should_compile/T25713.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/tcplugins/CtIdPlugin.hs
- testsuite/tests/th/Makefile
- testsuite/tests/th/T10267.stderr
- testsuite/tests/th/T14627.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/type-data/should_run/T22332a.stderr
- testsuite/tests/typecheck/should_compile/Makefile
- testsuite/tests/typecheck/should_compile/T12763.stderr
- testsuite/tests/typecheck/should_compile/T13050.stderr
- testsuite/tests/typecheck/should_compile/T14273.stderr
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/T14774.stdout
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- testsuite/tests/typecheck/should_compile/T25180.stderr
- + testsuite/tests/typecheck/should_compile/T25992a.hs
- + testsuite/tests/typecheck/should_compile/T26225.hs
- + testsuite/tests/typecheck/should_compile/T26225b.hs
- testsuite/tests/typecheck/should_compile/T9497a.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- − testsuite/tests/typecheck/should_fail/T12563.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T14618.stderr
- testsuite/tests/typecheck/should_fail/T14884.stderr
- testsuite/tests/typecheck/should_fail/T21130.stderr
- testsuite/tests/typecheck/should_fail/T23739b.stderr
- testsuite/tests/typecheck/should_fail/T23739c.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T6022.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T8883.stderr
- testsuite/tests/typecheck/should_fail/T9497d.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail037.stderr
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail140.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- testsuite/tests/typecheck/should_run/T10284.stderr
- testsuite/tests/typecheck/should_run/T13838.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- testsuite/tests/unboxedsums/unpack_sums_7.stdout
- testsuite/tests/unsatisfiable/T23816.stderr
- testsuite/tests/unsatisfiable/UnsatDefer.stderr
- testsuite/tests/vdq-rta/should_fail/T23738_fail_pun.stderr
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- testsuite/tests/wasm/should_run/control-flow/RunWasm.hs
- utils/deriveConstants/Main.hs
- utils/genprimopcode/Lexer.x
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Parser.y
- utils/genprimopcode/ParserM.hs
- utils/genprimopcode/Syntax.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afc3d72acc8fa4b402e811b43a7bea…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afc3d72acc8fa4b402e811b43a7bea…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/14554-wasm-fix] Deleted 1 commit: Read Toolchain.Target files rather than 'settings'
by Cheng Shao (＠TerrorJack) 24 Aug '25
by Cheng Shao (＠TerrorJack) 24 Aug '25
24 Aug '25
Cheng Shao pushed to branch wip/14554-wasm-fix at Glasgow Haskell Compiler / GHC
WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below.
Deleted commits:
c5f031f3 by Rodrigo Mesquita at 2025-08-23T19:21:31+02:00
Read Toolchain.Target files rather than 'settings'
This commit makes GHC read `lib/targets/default.target`, a file with a
serialized value of `ghc-toolchain`'s `GHC.Toolchain.Target`.
Moreover, it removes all the now-redundant entries from `lib/settings`
that are configured as part of a `Target` but were being written into
`settings`.
This makes it easier to support multiple targets from the same compiler
(aka runtime retargetability). `ghc-toolchain` can be re-run many times
standalone to produce a `Target` description for different targets, and,
in the future, GHC will be able to pick at runtime amongst different
`Target` files.
This commit only makes it read the default `Target` configured in-tree
or configured when installing the bindist.
The remaining bits of `settings` need to be moved to `Target` in follow
up commits, but ultimately they all should be moved since they are
per-target relevant.
Fixes #24212
On Windows, the constant overhead of parsing a slightly more complex
data structure causes some small-allocation tests to wiggle around 1 to
2 extra MB (1-2% in these cases).
-------------------------
Metric Increase:
MultiLayerModulesTH_OneShot
T10421
T10547
T12234
T12425
T13035
T18140
T18923
T9198
TcPlugin_RewritePerf
-------------------------
- - - - -
30 changed files:
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/SysTools/BaseDir.hs
- compiler/ghc.cabal.in
- configure.ac
- distrib/configure.ac.in
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/cfg/system.config.in
- hadrian/src/Base.hs
- hadrian/src/Rules/Generate.hs
- libraries/ghc-boot/GHC/Settings/Utils.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs
- − m4/fp_settings.m4
- m4/fp_setup_windows_toolchain.m4
- + m4/subst_tooldir.m4
- mk/hsc2hs.in
- testsuite/tests/ghc-api/T20757.hs
- testsuite/tests/ghc-api/settings-escape/T24265.hs
- testsuite/tests/ghc-api/settings-escape/T24265.stderr
- + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep
- utils/ghc-pkg/Main.hs
- utils/ghc-pkg/ghc-pkg.cabal.in
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs
Changes:
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -146,6 +146,7 @@ import qualified Data.Set as Set
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Toolchain.Target (Target)
-- -----------------------------------------------------------------------------
-- DynFlags
@@ -179,6 +180,7 @@ data DynFlags = DynFlags {
toolSettings :: {-# UNPACK #-} !ToolSettings,
platformMisc :: {-# UNPACK #-} !PlatformMisc,
rawSettings :: [(String, String)],
+ rawTarget :: Target,
tmpDir :: TempDir,
llvmOptLevel :: Int, -- ^ LLVM optimisation level
@@ -657,6 +659,7 @@ defaultDynFlags mySettings =
targetPlatform = sTargetPlatform mySettings,
platformMisc = sPlatformMisc mySettings,
rawSettings = sRawSettings mySettings,
+ rawTarget = sRawTarget mySettings,
tmpDir = panic "defaultDynFlags: uninitialized tmpDir",
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -280,6 +280,9 @@ import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))
import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
+import GHC.Toolchain
+import GHC.Toolchain.Program
+
import Data.IORef
import Control.Arrow ((&&&))
import Control.Monad
@@ -404,6 +407,7 @@ settings dflags = Settings
, sToolSettings = toolSettings dflags
, sPlatformMisc = platformMisc dflags
, sRawSettings = rawSettings dflags
+ , sRawTarget = rawTarget dflags
}
pgm_L :: DynFlags -> String
@@ -3455,9 +3459,58 @@ compilerInfo dflags
-- Next come the settings, so anything else can be overridden
-- in the settings file (as "lookup" uses the first match for the
-- key)
- : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))
- (rawSettings dflags)
- ++ [("Project version", projectVersion dflags),
+ : map (fmap expandDirectories)
+ (rawSettings dflags)
+ ++
+ [("C compiler command", queryCmd $ ccProgram . tgtCCompiler),
+ ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler),
+ ("C++ compiler command", queryCmd $ cxxProgram . tgtCxxCompiler),
+ ("C++ compiler flags", queryFlags $ cxxProgram . tgtCxxCompiler),
+ ("C compiler link flags", queryFlags $ ccLinkProgram . tgtCCompilerLink),
+ ("C compiler supports -no-pie", queryBool $ ccLinkSupportsNoPie . tgtCCompilerLink),
+ ("CPP command", queryCmd $ cppProgram . tgtCPreprocessor),
+ ("CPP flags", queryFlags $ cppProgram . tgtCPreprocessor),
+ ("Haskell CPP command", queryCmd $ hsCppProgram . tgtHsCPreprocessor),
+ ("Haskell CPP flags", queryFlags $ hsCppProgram . tgtHsCPreprocessor),
+ ("JavaScript CPP command", queryCmdMaybe jsCppProgram tgtJsCPreprocessor),
+ ("JavaScript CPP flags", queryFlagsMaybe jsCppProgram tgtJsCPreprocessor),
+ ("C-- CPP command", queryCmd $ cmmCppProgram . tgtCmmCPreprocessor),
+ ("C-- CPP flags", queryFlags $ cmmCppProgram . tgtCmmCPreprocessor),
+ ("C-- CPP supports -g0", queryBool $ cmmCppSupportsG0 . tgtCmmCPreprocessor),
+ ("ld supports compact unwind", queryBool $ ccLinkSupportsCompactUnwind . tgtCCompilerLink),
+ ("ld supports filelist", queryBool $ ccLinkSupportsFilelist . tgtCCompilerLink),
+ ("ld supports single module", queryBool $ ccLinkSupportsSingleModule . tgtCCompilerLink),
+ ("ld is GNU ld", queryBool $ ccLinkIsGnu . tgtCCompilerLink),
+ ("Merge objects command", queryCmdMaybe mergeObjsProgram tgtMergeObjs),
+ ("Merge objects flags", queryFlagsMaybe mergeObjsProgram tgtMergeObjs),
+ ("Merge objects supports response files", queryBool $ maybe False mergeObjsSupportsResponseFiles . tgtMergeObjs),
+ ("ar command", queryCmd $ arMkArchive . tgtAr),
+ ("ar flags", queryFlags $ arMkArchive . tgtAr),
+ ("ar supports at file", queryBool $ arSupportsAtFile . tgtAr),
+ ("ar supports -L", queryBool $ arSupportsDashL . tgtAr),
+ ("ranlib command", queryCmdMaybe ranlibProgram tgtRanlib),
+ ("otool command", queryCmdMaybe id tgtOtool),
+ ("install_name_tool command", queryCmdMaybe id tgtInstallNameTool),
+ ("windres command", queryCmd $ fromMaybe (Program "/bin/false" []) . tgtWindres),
+ ("cross compiling", queryBool (not . tgtLocallyExecutable)),
+ ("target platform string", query targetPlatformTriple),
+ ("target os", query (show . archOS_OS . tgtArchOs)),
+ ("target arch", query (show . archOS_arch . tgtArchOs)),
+ ("target word size", query $ show . wordSize2Bytes . tgtWordSize),
+ ("target word big endian", queryBool $ (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness),
+ ("target has GNU nonexec stack", queryBool tgtSupportsGnuNonexecStack),
+ ("target has .ident directive", queryBool tgtSupportsIdentDirective),
+ ("target has subsections via symbols", queryBool tgtSupportsSubsectionsViaSymbols),
+ ("Unregisterised", queryBool tgtUnregisterised),
+ ("LLVM target", query tgtLlvmTarget),
+ ("LLVM llc command", queryCmdMaybe id tgtLlc),
+ ("LLVM opt command", queryCmdMaybe id tgtOpt),
+ ("LLVM llvm-as command", queryCmdMaybe id tgtLlvmAs),
+ ("LLVM llvm-as flags", queryFlagsMaybe id tgtLlvmAs),
+ ("Tables next to code", queryBool tgtTablesNextToCode),
+ ("Leading underscore", queryBool tgtSymbolsHaveLeadingUnderscore)
+ ] ++
+ [("Project version", projectVersion dflags),
("Project Git commit id", cProjectGitCommitId),
("Project Version Int", cProjectVersionInt),
("Project Patch Level", cProjectPatchLevel),
@@ -3514,9 +3567,16 @@ compilerInfo dflags
showBool False = "NO"
platform = targetPlatform dflags
isWindows = platformOS platform == OSMinGW32
- useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags
- expandDirectories :: FilePath -> Maybe FilePath -> String -> String
- expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd
+ expandDirectories = expandToolDir (toolDir dflags) . expandTopDir (topDir dflags)
+ query :: (Target -> a) -> a
+ query f = f (rawTarget dflags)
+ queryFlags f = query (unwords . map escapeArg . prgFlags . f)
+ queryCmd f = expandDirectories (query (prgPath . f))
+ queryBool = showBool . query
+
+ queryCmdMaybe, queryFlagsMaybe :: (a -> Program) -> (Target -> Maybe a) -> String
+ queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f))
+ queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f)
-- Note [Special unit-ids]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -3844,3 +3904,19 @@ updatePlatformConstants dflags mconstants = do
let platform1 = (targetPlatform dflags) { platform_constants = mconstants }
let dflags1 = dflags { targetPlatform = platform1 }
return dflags1
+
+-- ----------------------------------------------------------------------------
+-- Escape Args helpers
+-- ----------------------------------------------------------------------------
+
+-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+ | isSpace c
+ || '\\' == c
+ || '\'' == c
+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
+ | otherwise = c:cs
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -23,7 +23,6 @@ module GHC.Settings
, sMergeObjsSupportsResponseFiles
, sLdIsGnuLd
, sGccSupportsNoPie
- , sUseInplaceMinGW
, sArSupportsDashL
, sPgm_L
, sPgm_P
@@ -75,6 +74,7 @@ import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
import GHC.Unit.Types
+import GHC.Toolchain.Target
data Settings = Settings
{ sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion
@@ -87,6 +87,10 @@ data Settings = Settings
-- You shouldn't need to look things up in rawSettings directly.
-- They should have their own fields instead.
, sRawSettings :: [(String, String)]
+
+ -- Store the target to print out information about the raw target description
+ -- (e.g. in --info)
+ , sRawTarget :: Target
}
data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId }
@@ -102,7 +106,6 @@ data ToolSettings = ToolSettings
, toolSettings_mergeObjsSupportsResponseFiles :: Bool
, toolSettings_ldIsGnuLd :: Bool
, toolSettings_ccSupportsNoPie :: Bool
- , toolSettings_useInplaceMinGW :: Bool
, toolSettings_arSupportsDashL :: Bool
, toolSettings_cmmCppSupportsG0 :: Bool
@@ -221,8 +224,6 @@ sLdIsGnuLd :: Settings -> Bool
sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings
sGccSupportsNoPie :: Settings -> Bool
sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings
-sUseInplaceMinGW :: Settings -> Bool
-sUseInplaceMinGW = toolSettings_useInplaceMinGW . sToolSettings
sArSupportsDashL :: Settings -> Bool
sArSupportsDashL = toolSettings_arSupportsDashL . sToolSettings
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -16,18 +16,20 @@ import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
import GHC.Utils.Panic
-import GHC.ResponseFile
import GHC.Settings
import GHC.SysTools.BaseDir
import GHC.Unit.Types
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
-import Data.Char
import qualified Data.Map as Map
import System.FilePath
import System.Directory
+import GHC.Toolchain.Program
+import GHC.Toolchain
+import GHC.Data.Maybe
+import Data.Bifunctor (Bifunctor(second))
data SettingsError
= SettingsError_MissingData String
@@ -44,6 +46,7 @@ initSettings top_dir = do
libexec :: FilePath -> FilePath
libexec file = top_dir </> ".." </> "bin" </> file
settingsFile = installed "settings"
+ targetFile = installed $ "targets" </> "default.target"
readFileSafe :: FilePath -> ExceptT SettingsError m String
readFileSafe path = liftIO (doesFileExist path) >>= \case
@@ -55,85 +58,72 @@ initSettings top_dir = do
Just s -> pure s
Nothing -> throwE $ SettingsError_BadData $
"Can't parse " ++ show settingsFile
+ targetStr <- readFileSafe targetFile
+ target <- case maybeReadFuzzy @Target targetStr of
+ Just s -> pure s
+ Nothing -> throwE $ SettingsError_BadData $
+ "Can't parse as Target " ++ show targetFile
let mySettings = Map.fromList settingsList
getBooleanSetting :: String -> ExceptT SettingsError m Bool
getBooleanSetting key = either pgmError pure $
getRawBooleanSetting settingsFile mySettings key
- -- On Windows, by mingw is often distributed with GHC,
- -- so we look in TopDir/../mingw/bin,
- -- as well as TopDir/../../mingw/bin for hadrian.
- -- But we might be disabled, in which we we don't do that.
- useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"
-
-- see Note [topdir: How GHC finds its files]
-- NB: top_dir is assumed to be in standard Unix
-- format, '/' separated
- mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir
+ mtool_dir <- liftIO $ findToolDir top_dir
-- see Note [tooldir: How GHC finds mingw on Windows]
- -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally
- -- introduce unescaped spaces. See #24265 and #25204.
- let escaped_top_dir = escapeArg top_dir
- escaped_mtool_dir = fmap escapeArg mtool_dir
-
- getSetting_raw key = either pgmError pure $
+ let getSetting_raw key = either pgmError pure $
getRawSetting settingsFile mySettings key
getSetting_topDir top key = either pgmError pure $
getRawFilePathSetting top settingsFile mySettings key
getSetting_toolDir top tool key =
- expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key
-
- getSetting :: String -> ExceptT SettingsError m String
+ expandToolDir tool <$> getSetting_topDir top key
getSetting key = getSetting_topDir top_dir key
- getToolSetting :: String -> ExceptT SettingsError m String
getToolSetting key = getSetting_toolDir top_dir mtool_dir key
- getFlagsSetting :: String -> ExceptT SettingsError m [String]
- getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key
- -- Make sure to unescape, as we have escaped top_dir and tool_dir.
+
+ expandDirVars top tool = expandToolDir tool . expandTopDir top
+
+ getToolPath :: (Target -> Program) -> String
+ getToolPath key = expandDirVars top_dir mtool_dir (prgPath . key $ target)
+
+ getMaybeToolPath :: (Target -> Maybe Program) -> String
+ getMaybeToolPath key = getToolPath (fromMaybe (Program "" []) . key)
+
+ getToolFlags :: (Target -> Program) -> [String]
+ getToolFlags key = expandDirVars top_dir mtool_dir <$> (prgFlags . key $ target)
+
+ getTool :: (Target -> Program) -> (String, [String])
+ getTool key = (getToolPath key, getToolFlags key)
-- See Note [Settings file] for a little more about this file. We're
-- just partially applying those functions and throwing 'Left's; they're
-- written in a very portable style to keep ghc-boot light.
- targetPlatformString <- getSetting_raw "target platform string"
- cc_prog <- getToolSetting "C compiler command"
- cxx_prog <- getToolSetting "C++ compiler command"
- cc_args0 <- getFlagsSetting "C compiler flags"
- cxx_args <- getFlagsSetting "C++ compiler flags"
- gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
- cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0"
- cpp_prog <- getToolSetting "CPP command"
- cpp_args <- map Option <$> getFlagsSetting "CPP flags"
- hs_cpp_prog <- getToolSetting "Haskell CPP command"
- hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags"
- js_cpp_prog <- getToolSetting "JavaScript CPP command"
- js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags"
- cmmCpp_prog <- getToolSetting "C-- CPP command"
- cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags"
-
- platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings
-
- let unreg_cc_args = if platformUnregisterised platform
- then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
- else []
- cc_args = cc_args0 ++ unreg_cc_args
-
- -- The extra flags we need to pass gcc when we invoke it to compile .hc code.
- --
- -- -fwrapv is needed for gcc to emit well-behaved code in the presence of
- -- integer wrap around (#952).
- extraGccViaCFlags = if platformUnregisterised platform
- -- configure guarantees cc support these flags
- then ["-fwrapv", "-fno-builtin"]
- else []
-
- ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
- ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
- ldSupportsSingleModule <- getBooleanSetting "ld supports single module"
- mergeObjsSupportsResponseFiles <- getBooleanSetting "Merge objects supports response files"
- ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
- arSupportsDashL <- getBooleanSetting "ar supports -L"
-
+ targetHasLibm <- getBooleanSetting "target has libm"
+ let
+ (cc_prog, cc_args0) = getTool (ccProgram . tgtCCompiler)
+ (cxx_prog, cxx_args) = getTool (cxxProgram . tgtCxxCompiler)
+ (cpp_prog, cpp_args) = getTool (cppProgram . tgtCPreprocessor)
+ (hs_cpp_prog, hs_cpp_args) = getTool (hsCppProgram . tgtHsCPreprocessor)
+ (js_cpp_prog, js_cpp_args) = getTool (maybe (Program "" []) jsCppProgram . tgtJsCPreprocessor)
+ (cmmCpp_prog, cmmCpp_args) = getTool (cmmCppProgram . tgtCmmCPreprocessor)
+
+ platform = getTargetPlatform targetHasLibm target
+
+ unreg_cc_args = if platformUnregisterised platform
+ then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
+ else []
+ cc_args = cc_args0 ++ unreg_cc_args
+
+ -- The extra flags we need to pass gcc when we invoke it to compile .hc code.
+ --
+ -- -fwrapv is needed for gcc to emit well-behaved code in the presence of
+ -- integer wrap around (#952).
+ extraGccViaCFlags = if platformUnregisterised platform
+ -- configure guarantees cc support these flags
+ then ["-fwrapv", "-fno-builtin"]
+ else []
-- The package database is either a relative path to the location of the settings file
-- OR an absolute path.
@@ -148,41 +138,20 @@ initSettings top_dir = do
-- architecture-specific stuff is done when building Config.hs
unlit_path <- getToolSetting "unlit command"
- windres_path <- getToolSetting "windres command"
- ar_path <- getToolSetting "ar command"
- otool_path <- getToolSetting "otool command"
- install_name_tool_path <- getToolSetting "install_name_tool command"
- ranlib_path <- getToolSetting "ranlib command"
-
- -- HACK, see setPgmP below. We keep 'words' here to remember to fix
- -- Config.hs one day.
-
-
- -- Other things being equal, 'as' and 'ld' are simply 'gcc'
- cc_link_args <- getFlagsSetting "C compiler link flags"
- let as_prog = cc_prog
- as_args = map Option cc_args
- ld_prog = cc_prog
- ld_args = map Option (cc_args ++ cc_link_args)
- ld_r_prog <- getToolSetting "Merge objects command"
- ld_r_args <- getFlagsSetting "Merge objects flags"
- let ld_r
- | null ld_r_prog = Nothing
- | otherwise = Just (ld_r_prog, map Option ld_r_args)
-
- llvmTarget <- getSetting_raw "LLVM target"
-
- -- We just assume on command line
- lc_prog <- getToolSetting "LLVM llc command"
- lo_prog <- getToolSetting "LLVM opt command"
- las_prog <- getToolSetting "LLVM llvm-as command"
- las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags"
-
- let iserv_prog = libexec "ghc-iserv"
+ -- Other things being equal, 'as' is simply 'gcc'
+ let (cc_link, cc_link_args) = getTool (ccLinkProgram . tgtCCompilerLink)
+ as_prog = cc_prog
+ as_args = map Option cc_args
+ ld_prog = cc_link
+ ld_args = map Option (cc_args ++ cc_link_args)
+ ld_r = do
+ ld_r_prog <- tgtMergeObjs target
+ let (ld_r_path, ld_r_args) = getTool (mergeObjsProgram . const ld_r_prog)
+ pure (ld_r_path, map Option ld_r_args)
+ iserv_prog = libexec "ghc-iserv"
targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries"
ghcWithInterpreter <- getBooleanSetting "Use interpreter"
- useLibFFI <- getBooleanSetting "Use LibFFI"
baseUnitId <- getSetting_raw "base unit-id"
@@ -206,36 +175,38 @@ initSettings top_dir = do
}
, sToolSettings = ToolSettings
- { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
- , toolSettings_ldSupportsFilelist = ldSupportsFilelist
- , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule
- , toolSettings_mergeObjsSupportsResponseFiles = mergeObjsSupportsResponseFiles
- , toolSettings_ldIsGnuLd = ldIsGnuLd
- , toolSettings_ccSupportsNoPie = gccSupportsNoPie
- , toolSettings_useInplaceMinGW = useInplaceMinGW
- , toolSettings_arSupportsDashL = arSupportsDashL
- , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0
-
- , toolSettings_pgm_L = unlit_path
- , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args)
- , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args)
- , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args)
- , toolSettings_pgm_F = ""
- , toolSettings_pgm_c = cc_prog
- , toolSettings_pgm_cxx = cxx_prog
- , toolSettings_pgm_cpp = (cpp_prog, cpp_args)
- , toolSettings_pgm_a = (as_prog, as_args)
- , toolSettings_pgm_l = (ld_prog, ld_args)
- , toolSettings_pgm_lm = ld_r
- , toolSettings_pgm_windres = windres_path
- , toolSettings_pgm_ar = ar_path
- , toolSettings_pgm_otool = otool_path
- , toolSettings_pgm_install_name_tool = install_name_tool_path
- , toolSettings_pgm_ranlib = ranlib_path
- , toolSettings_pgm_lo = (lo_prog,[])
- , toolSettings_pgm_lc = (lc_prog,[])
- , toolSettings_pgm_las = (las_prog, las_args)
- , toolSettings_pgm_i = iserv_prog
+ { toolSettings_ldSupportsCompactUnwind = ccLinkSupportsCompactUnwind $ tgtCCompilerLink target
+ , toolSettings_ldSupportsFilelist = ccLinkSupportsFilelist $ tgtCCompilerLink target
+ , toolSettings_ldSupportsSingleModule = ccLinkSupportsSingleModule $ tgtCCompilerLink target
+ , toolSettings_ldIsGnuLd = ccLinkIsGnu $ tgtCCompilerLink target
+ , toolSettings_ccSupportsNoPie = ccLinkSupportsNoPie $ tgtCCompilerLink target
+ , toolSettings_mergeObjsSupportsResponseFiles
+ = maybe False mergeObjsSupportsResponseFiles
+ $ tgtMergeObjs target
+ , toolSettings_arSupportsDashL = arSupportsDashL $ tgtAr target
+ , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 $ tgtCmmCPreprocessor target
+
+ , toolSettings_pgm_L = unlit_path
+ , toolSettings_pgm_P = (hs_cpp_prog, map Option hs_cpp_args)
+ , toolSettings_pgm_JSP = (js_cpp_prog, map Option js_cpp_args)
+ , toolSettings_pgm_CmmP = (cmmCpp_prog, map Option cmmCpp_args)
+ , toolSettings_pgm_F = ""
+ , toolSettings_pgm_c = cc_prog
+ , toolSettings_pgm_cxx = cxx_prog
+ , toolSettings_pgm_cpp = (cpp_prog, map Option cpp_args)
+ , toolSettings_pgm_a = (as_prog, as_args)
+ , toolSettings_pgm_l = (ld_prog, ld_args)
+ , toolSettings_pgm_lm = ld_r
+ , toolSettings_pgm_windres = getMaybeToolPath tgtWindres
+ , toolSettings_pgm_ar = getToolPath (arMkArchive . tgtAr)
+ , toolSettings_pgm_otool = getMaybeToolPath tgtOtool
+ , toolSettings_pgm_install_name_tool = getMaybeToolPath tgtInstallNameTool
+ , toolSettings_pgm_ranlib = getMaybeToolPath (fmap ranlibProgram . tgtRanlib)
+ , toolSettings_pgm_lo = (getMaybeToolPath tgtOpt,[])
+ , toolSettings_pgm_lc = (getMaybeToolPath tgtLlc,[])
+ , toolSettings_pgm_las = second (map Option) $
+ getTool (fromMaybe (Program "" []) . tgtLlvmAs)
+ , toolSettings_pgm_i = iserv_prog
, toolSettings_opt_L = []
, toolSettings_opt_P = []
, toolSettings_opt_JSP = []
@@ -260,65 +231,30 @@ initSettings top_dir = do
, sTargetPlatform = platform
, sPlatformMisc = PlatformMisc
- { platformMisc_targetPlatformString = targetPlatformString
+ { platformMisc_targetPlatformString = targetPlatformTriple target
, platformMisc_ghcWithInterpreter = ghcWithInterpreter
- , platformMisc_libFFI = useLibFFI
- , platformMisc_llvmTarget = llvmTarget
+ , platformMisc_libFFI = tgtUseLibffiForAdjustors target
+ , platformMisc_llvmTarget = tgtLlvmTarget target
, platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs
}
, sRawSettings = settingsList
+ , sRawTarget = target
}
-getTargetPlatform
- :: FilePath -- ^ Settings filepath (for error messages)
- -> RawSettings -- ^ Raw settings file contents
- -> Either String Platform
-getTargetPlatform settingsFile settings = do
- let
- getBooleanSetting = getRawBooleanSetting settingsFile settings
- readSetting :: (Show a, Read a) => String -> Either String a
- readSetting = readRawSetting settingsFile settings
-
- targetArchOS <- getTargetArchOS settingsFile settings
- targetWordSize <- readSetting "target word size"
- targetWordBigEndian <- getBooleanSetting "target word big endian"
- targetLeadingUnderscore <- getBooleanSetting "Leading underscore"
- targetUnregisterised <- getBooleanSetting "Unregisterised"
- targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"
- targetHasIdentDirective <- getBooleanSetting "target has .ident directive"
- targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"
- targetHasLibm <- getBooleanSetting "target has libm"
- crossCompiling <- getBooleanSetting "cross compiling"
- tablesNextToCode <- getBooleanSetting "Tables next to code"
-
- pure $ Platform
- { platformArchOS = targetArchOS
- , platformWordSize = targetWordSize
- , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian
- , platformUnregisterised = targetUnregisterised
- , platformHasGnuNonexecStack = targetHasGnuNonexecStack
- , platformHasIdentDirective = targetHasIdentDirective
- , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
- , platformIsCrossCompiling = crossCompiling
- , platformLeadingUnderscore = targetLeadingUnderscore
- , platformTablesNextToCode = tablesNextToCode
+getTargetPlatform :: Bool {-^ Does target have libm -} -> Target -> Platform
+getTargetPlatform targetHasLibm Target{..} = Platform
+ { platformArchOS = tgtArchOs
+ , platformWordSize = case tgtWordSize of WS4 -> PW4
+ WS8 -> PW8
+ , platformByteOrder = tgtEndianness
+ , platformUnregisterised = tgtUnregisterised
+ , platformHasGnuNonexecStack = tgtSupportsGnuNonexecStack
+ , platformHasIdentDirective = tgtSupportsIdentDirective
+ , platformHasSubsectionsViaSymbols = tgtSupportsSubsectionsViaSymbols
+ , platformIsCrossCompiling = not tgtLocallyExecutable
+ , platformLeadingUnderscore = tgtSymbolsHaveLeadingUnderscore
+ , platformTablesNextToCode = tgtTablesNextToCode
, platformHasLibm = targetHasLibm
, platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit
}
-
--- ----------------------------------------------------------------------------
--- Escape Args helpers
--- ----------------------------------------------------------------------------
-
--- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
-escapeArg :: String -> String
-escapeArg = reverse . foldl' escape []
-
-escape :: String -> Char -> String
-escape cs c
- | isSpace c
- || '\\' == c
- || '\'' == c
- || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
- | otherwise = c:cs
=====================================
compiler/GHC/SysTools/BaseDir.hs
=====================================
@@ -90,13 +90,10 @@ the build system finds and wires through the toolchain information.
3) The next step is to generate the settings file: The file
`cfg/system.config.in` is preprocessed by configure and the output written to
`system.config`. This serves the same purpose as `config.mk` but it rewrites
- the values that were exported. As an example `SettingsCCompilerCommand` is
- rewritten to `settings-c-compiler-command`.
+ the values that were exported.
Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to
- the settings `keys` in the `system.config`. As an example,
- `settings-c-compiler-command` is mapped to
- `SettingsFileSetting_CCompilerCommand`.
+ the settings `keys` in the `system.config`.
The last part of this is the `generateSettings` in `src/Rules/Generate.hs`
which produces the desired settings file out of Hadrian. This is the
@@ -122,15 +119,13 @@ play nice with the system compiler instead.
-- | Expand occurrences of the @$tooldir@ interpolation in a string
-- on Windows, leave the string untouched otherwise.
expandToolDir
- :: Bool -- ^ whether we use the ambient mingw toolchain
- -> Maybe FilePath -- ^ tooldir
+ :: Maybe FilePath -- ^ tooldir
-> String -> String
#if defined(mingw32_HOST_OS)
-expandToolDir False (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
-expandToolDir False Nothing _ = panic "Could not determine $tooldir"
-expandToolDir True _ s = s
+expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
+expandToolDir Nothing _ = panic "Could not determine $tooldir"
#else
-expandToolDir _ _ s = s
+expandToolDir _ s = s
#endif
-- | Returns a Unix-format path pointing to TopDir.
@@ -164,13 +159,13 @@ tryFindTopDir Nothing
-- Returns @Nothing@ when not on Windows.
-- When called on Windows, it either throws an error when the
-- tooldir can't be located, or returns @Just tooldirpath@.
--- If the distro toolchain is being used we treat Windows the same as Linux
+-- If the distro toolchain is being used, there will be no variables to
+-- substitute for anyway, so this is a no-op.
findToolDir
- :: Bool -- ^ whether we use the ambient mingw toolchain
- -> FilePath -- ^ topdir
+ :: FilePath -- ^ topdir
-> IO (Maybe FilePath)
#if defined(mingw32_HOST_OS)
-findToolDir False top_dir = go 0 (top_dir </> "..") []
+findToolDir top_dir = go 0 (top_dir </> "..") []
where maxDepth = 3
go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath)
go k path tried
@@ -183,7 +178,6 @@ findToolDir False top_dir = go 0 (top_dir </> "..") []
if oneLevel
then return (Just path)
else go (k+1) (path </> "..") tried'
-findToolDir True _ = return Nothing
#else
-findToolDir _ _ = return Nothing
+findToolDir _ = return Nothing
#endif
=====================================
compiler/ghc.cabal.in
=====================================
@@ -131,6 +131,7 @@ Library
semaphore-compat,
stm,
rts,
+ ghc-toolchain,
ghc-boot == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
ghci == @ProjectVersionMunged@
=====================================
configure.ac
=====================================
@@ -132,6 +132,7 @@ AC_ARG_ENABLE(distro-toolchain,
[FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])],
[EnableDistroToolchain=NO]
)
+AC_SUBST([EnableDistroToolchain])
if test "$EnableDistroToolchain" = "YES"; then
TarballsAutodownload=NO
@@ -760,8 +761,6 @@ FP_PROG_AR_NEEDS_RANLIB
dnl ** Check to see whether ln -s works
AC_PROG_LN_S
-FP_SETTINGS
-
dnl ** Find the path to sed
AC_PATH_PROGS(SedCmd,gsed sed,sed)
=====================================
distrib/configure.ac.in
=====================================
@@ -89,8 +89,9 @@ AC_ARG_ENABLE(distro-toolchain,
[AS_HELP_STRING([--enable-distro-toolchain],
[Do not use bundled Windows toolchain binaries.])],
[FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])],
- [EnableDistroToolchain=@SettingsUseDistroMINGW@]
+ [EnableDistroToolchain=@EnableDistroToolchain@]
)
+AC_SUBST([EnableDistroToolchain])
if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then
FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/])
@@ -384,8 +385,6 @@ fi
AC_SUBST(BaseUnitId)
-FP_SETTINGS
-
# We get caught by
# http://savannah.gnu.org/bugs/index.php?1516
# $(eval ...) inside conditionals causes errors
@@ -418,6 +417,34 @@ AC_OUTPUT
VALIDATE_GHC_TOOLCHAIN([default.target],[default.target.ghc-toolchain])
+if test "$EnableDistroToolchain" = "YES"; then
+ # If the user specified --enable-distro-toolchain then we just use the
+ # executable names, not paths. We do this by finding strings of paths to
+ # programs and keeping the basename only:
+ cp default.target default.target.bak
+
+ while IFS= read -r line; do
+ if echo "$line" | grep -q 'prgPath = "'; then
+ path=$(echo "$line" | sed -E 's/.*prgPath = "([[^"]]+)".*/\1/')
+ base=$(basename "$path")
+ echo "$line" | sed "s|$path|$base|"
+ else
+ echo "$line"
+ fi
+ done < default.target.bak > default.target
+ echo "Applied --enable-distro-toolchain basename substitution to default.target:"
+ cat default.target
+fi
+
+if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then
+ # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN.
+ # We need to issue a substitution to use $tooldir,
+ # See Note [tooldir: How GHC finds mingw on Windows]
+ SUBST_TOOLDIR([default.target])
+ echo "Applied tooldir substitution to default.target:"
+ cat default.target
+fi
+
rm -Rf acargs acghc-toolchain actmp-ghc-toolchain
echo "****************************************************"
=====================================
hadrian/bindist/Makefile
=====================================
@@ -85,67 +85,22 @@ WrapperBinsDir=${bindir}
# N.B. this is duplicated from includes/ghc.mk.
lib/settings : config.mk
@rm -f $@
- @echo '[("C compiler command", "$(SettingsCCompilerCommand)")' >> $@
- @echo ',("C compiler flags", "$(SettingsCCompilerFlags)")' >> $@
- @echo ',("C++ compiler command", "$(SettingsCxxCompilerCommand)")' >> $@
- @echo ',("C++ compiler flags", "$(SettingsCxxCompilerFlags)")' >> $@
- @echo ',("C compiler link flags", "$(SettingsCCompilerLinkFlags)")' >> $@
- @echo ',("C compiler supports -no-pie", "$(SettingsCCompilerSupportsNoPie)")' >> $@
- @echo ',("CPP command", "$(SettingsCPPCommand)")' >> $@
- @echo ',("CPP flags", "$(SettingsCPPFlags)")' >> $@
- @echo ',("Haskell CPP command", "$(SettingsHaskellCPPCommand)")' >> $@
- @echo ',("Haskell CPP flags", "$(SettingsHaskellCPPFlags)")' >> $@
- @echo ',("JavaScript CPP command", "$(SettingsJavaScriptCPPCommand)")' >> $@
- @echo ',("JavaScript CPP flags", "$(SettingsJavaScriptCPPFlags)")' >> $@
- @echo ',("C-- CPP command", "$(SettingsCmmCPPCommand)")' >> $@
- @echo ',("C-- CPP flags", "$(SettingsCmmCPPFlags)")' >> $@
- @echo ',("C-- CPP supports -g0", "$(SettingsCmmCPPSupportsG0)")' >> $@
- @echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
- @echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
- @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@
- @echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
- @echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
- @echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@
- @echo ',("Merge objects supports response files", "$(MergeObjsSupportsResponseFiles)")' >> $@
- @echo ',("ar command", "$(SettingsArCommand)")' >> $@
- @echo ',("ar flags", "$(ArArgs)")' >> $@
- @echo ',("ar supports at file", "$(ArSupportsAtFile)")' >> $@
- @echo ',("ar supports -L", "$(ArSupportsDashL)")' >> $@
- @echo ',("ranlib command", "$(SettingsRanlibCommand)")' >> $@
- @echo ',("otool command", "$(SettingsOtoolCommand)")' >> $@
- @echo ',("install_name_tool command", "$(SettingsInstallNameToolCommand)")' >> $@
- @echo ',("windres command", "$(SettingsWindresCommand)")' >> $@
+ @echo '[("target has libm", "$(TargetHasLibm)")' >> $@
@echo ',("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@
- @echo ',("cross compiling", "$(CrossCompiling)")' >> $@
- @echo ',("target platform string", "$(TARGETPLATFORM)")' >> $@
- @echo ',("target os", "$(HaskellTargetOs)")' >> $@
- @echo ',("target arch", "$(HaskellTargetArch)")' >> $@
- @echo ',("target word size", "$(TargetWordSize)")' >> $@
- @echo ',("target word big endian", "$(TargetWordBigEndian)")' >> $@
- @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@
- @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@
- @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@
- @echo ',("target has libm", "$(TargetHasLibm)")' >> $@
- @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@
- @echo ',("LLVM target", "$(LLVMTarget)")' >> $@
- @echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@
- @echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@
- @echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@
- @echo ',("LLVM llvm-as flags", "$(SettingsLlvmAsFlags)")' >> $@
- @echo ',("Use inplace MinGW toolchain", "$(SettingsUseDistroMINGW)")' >> $@
- @echo
@echo ',("target RTS linker only supports shared libraries", "$(TargetRTSLinkerOnlySupportsSharedLibs)")' >> $@
@echo ',("Use interpreter", "$(GhcWithInterpreter)")' >> $@
@echo ',("Support SMP", "$(GhcWithSMP)")' >> $@
@echo ',("RTS ways", "$(GhcRTSWays)")' >> $@
- @echo ',("Tables next to code", "$(TablesNextToCode)")' >> $@
- @echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@
- @echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@
@echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@
@echo ',("Relative Global Package DB", "package.conf.d")' >> $@
@echo ',("base unit-id", "$(BaseUnitId)")' >> $@
@echo "]" >> $@
+lib/targets/default.target : config.mk default.target
+ @rm -f $@
+ @echo "Copying the bindist-configured default.target to lib/targets/default.target"
+ cp default.target $@
+
# We need to install binaries relative to libraries.
BINARIES = $(wildcard ./bin/*)
.PHONY: install_bin_libdir
@@ -167,7 +122,7 @@ install_bin_direct:
$(INSTALL_PROGRAM) ./bin/* "$(DESTDIR)$(WrapperBinsDir)/"
.PHONY: install_lib
-install_lib: lib/settings
+install_lib: lib/settings lib/targets/default.target
@echo "Copying libraries to $(DESTDIR)$(ActualLibsDir)"
$(INSTALL_DIR) "$(DESTDIR)$(ActualLibsDir)"
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -133,7 +133,7 @@ INSTALL_DIR = $(INSTALL) -m 755 -d
CrossCompiling = @CrossCompiling@
CrossCompilePrefix = @CrossCompilePrefix@
GhcUnregisterised = @Unregisterised@
-EnableDistroToolchain = @SettingsUseDistroMINGW@
+EnableDistroToolchain = @EnableDistroToolchain@
BaseUnitId = @BaseUnitId@
# The THREADED_RTS requires `BaseReg` to be in a register and the
@@ -205,31 +205,3 @@ TargetHasLibm = @TargetHasLibm@
TablesNextToCode = @TablesNextToCode@
LeadingUnderscore = @LeadingUnderscore@
LlvmTarget = @LlvmTarget@
-
-SettingsCCompilerCommand = @SettingsCCompilerCommand@
-SettingsCxxCompilerCommand = @SettingsCxxCompilerCommand@
-SettingsCPPCommand = @SettingsCPPCommand@
-SettingsCPPFlags = @SettingsCPPFlags@
-SettingsHaskellCPPCommand = @SettingsHaskellCPPCommand@
-SettingsHaskellCPPFlags = @SettingsHaskellCPPFlags@
-SettingsJavaScriptCPPCommand = @SettingsJavaScriptCPPCommand@
-SettingsJavaScriptCPPFlags = @SettingsJavaScriptCPPFlags@
-SettingsCmmCPPCommand = @SettingsCmmCPPCommand@
-SettingsCmmCPPFlags = @SettingsCmmCPPFlags@
-SettingsCmmCPPSupportsG0 = @SettingsCmmCPPSupportsG0@
-SettingsCCompilerFlags = @SettingsCCompilerFlags@
-SettingsCxxCompilerFlags = @SettingsCxxCompilerFlags@
-SettingsCCompilerLinkFlags = @SettingsCCompilerLinkFlags@
-SettingsCCompilerSupportsNoPie = @SettingsCCompilerSupportsNoPie@
-SettingsMergeObjectsCommand = @SettingsMergeObjectsCommand@
-SettingsMergeObjectsFlags = @SettingsMergeObjectsFlags@
-SettingsArCommand = @SettingsArCommand@
-SettingsOtoolCommand = @SettingsOtoolCommand@
-SettingsInstallNameToolCommand = @SettingsInstallNameToolCommand@
-SettingsRanlibCommand = @SettingsRanlibCommand@
-SettingsWindresCommand = @SettingsWindresCommand@
-SettingsLibtoolCommand = @SettingsLibtoolCommand@
-SettingsLlcCommand = @SettingsLlcCommand@
-SettingsOptCommand = @SettingsOptCommand@
-SettingsLlvmAsCommand = @SettingsLlvmAsCommand@
-SettingsUseDistroMINGW = @SettingsUseDistroMINGW@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -79,7 +79,7 @@ project-git-commit-id = @ProjectGitCommitId@
# generated by configure, to generated being by the build system. Many of these
# might become redundant.
# See Note [tooldir: How GHC finds mingw on Windows]
-settings-use-distro-mingw = @SettingsUseDistroMINGW@
+settings-use-distro-mingw = @EnableDistroToolchain@
target-has-libm = @TargetHasLibm@
=====================================
hadrian/src/Base.hs
=====================================
@@ -151,6 +151,7 @@ ghcLibDeps stage iplace = do
, "llvm-passes"
, "ghc-interp.js"
, "settings"
+ , "targets" -/- "default.target"
, "ghc-usage.txt"
, "ghci-usage.txt"
, "dyld.mjs"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -10,7 +10,7 @@ import qualified Data.Set as Set
import Base
import qualified Context
import Expression
-import Hadrian.Oracles.TextFile (lookupSystemConfig)
+import Hadrian.Oracles.TextFile (lookupSystemConfig, getTargetTarget)
import Oracles.Flag hiding (arSupportsAtFile, arSupportsDashL)
import Oracles.ModuleFiles
import Oracles.Setting
@@ -24,7 +24,6 @@ import Target
import Utilities
import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp))
-import GHC.Toolchain.Program
import GHC.Platform.ArchOS
import Settings.Program (ghcWithInterpreter)
@@ -263,6 +262,7 @@ generateRules = do
let prefix = root -/- stageString stage -/- "lib"
go gen file = generate file (semiEmptyTarget (succStage stage)) gen
(prefix -/- "settings") %> \out -> go (generateSettings out) out
+ (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out
where
file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out
@@ -425,7 +425,7 @@ bindistRules = do
, interpolateSetting "LlvmMinVersion" LlvmMinVersion
, interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget
, interpolateSetting "ProjectVersion" ProjectVersion
- , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw"
+ , interpolateVar "EnableDistroToolchain" $ lookupSystemConfig "settings-use-distro-mingw"
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm"
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
@@ -483,62 +483,12 @@ generateSettings settingsFile = do
let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
settings <- traverse sequence $
- [ ("C compiler command", queryTarget ccPath)
- , ("C compiler flags", queryTarget ccFlags)
- , ("C++ compiler command", queryTarget cxxPath)
- , ("C++ compiler flags", queryTarget cxxFlags)
- , ("C compiler link flags", queryTarget clinkFlags)
- , ("C compiler supports -no-pie", queryTarget linkSupportsNoPie)
- , ("CPP command", queryTarget cppPath)
- , ("CPP flags", queryTarget cppFlags)
- , ("Haskell CPP command", queryTarget hsCppPath)
- , ("Haskell CPP flags", queryTarget hsCppFlags)
- , ("JavaScript CPP command", queryTarget jsCppPath)
- , ("JavaScript CPP flags", queryTarget jsCppFlags)
- , ("C-- CPP command", queryTarget cmmCppPath)
- , ("C-- CPP flags", queryTarget cmmCppFlags)
- , ("C-- CPP supports -g0", queryTarget cmmCppSupportsG0')
- , ("ld supports compact unwind", queryTarget linkSupportsCompactUnwind)
- , ("ld supports filelist", queryTarget linkSupportsFilelist)
- , ("ld supports single module", queryTarget linkSupportsSingleModule)
- , ("ld is GNU ld", queryTarget linkIsGnu)
- , ("Merge objects command", queryTarget mergeObjsPath)
- , ("Merge objects flags", queryTarget mergeObjsFlags)
- , ("Merge objects supports response files", queryTarget mergeObjsSupportsResponseFiles')
- , ("ar command", queryTarget arPath)
- , ("ar flags", queryTarget arFlags)
- , ("ar supports at file", queryTarget arSupportsAtFile')
- , ("ar supports -L", queryTarget arSupportsDashL')
- , ("ranlib command", queryTarget ranlibPath)
- , ("otool command", queryTarget otoolPath)
- , ("install_name_tool command", queryTarget installNameToolPath)
- , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me.
- , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
- , ("cross compiling", expr $ yesNo <$> flag CrossCompiling)
- , ("target platform string", queryTarget targetPlatformTriple)
- , ("target os", queryTarget (show . archOS_OS . tgtArchOs))
- , ("target arch", queryTarget (show . archOS_arch . tgtArchOs))
- , ("target word size", queryTarget wordSize)
- , ("target word big endian", queryTarget isBigEndian)
- , ("target has GNU nonexec stack", queryTarget (yesNo . Toolchain.tgtSupportsGnuNonexecStack))
- , ("target has .ident directive", queryTarget (yesNo . Toolchain.tgtSupportsIdentDirective))
- , ("target has subsections via symbols", queryTarget (yesNo . Toolchain.tgtSupportsSubsectionsViaSymbols))
+ [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
, ("target has libm", expr $ lookupSystemConfig "target-has-libm")
- , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised))
- , ("LLVM target", queryTarget tgtLlvmTarget)
- , ("LLVM llc command", queryTarget llcPath)
- , ("LLVM opt command", queryTarget optPath)
- , ("LLVM llvm-as command", queryTarget llvmAsPath)
- , ("LLVM llvm-as flags", queryTarget llvmAsFlags)
- , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw")
-
, ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs)
, ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage))
, ("Support SMP", expr $ yesNo <$> targetSupportsSMP)
, ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays)
- , ("Tables next to code", queryTarget (yesNo . tgtTablesNextToCode))
- , ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
- , ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
, ("Relative Global Package DB", pure rel_pkg_db)
, ("base unit-id", pure base_unit_id)
@@ -550,40 +500,6 @@ generateSettings settingsFile = do
("[" ++ showTuple s)
: ((\s' -> "," ++ showTuple s') <$> ss)
++ ["]"]
- where
- ccPath = prgPath . ccProgram . tgtCCompiler
- ccFlags = escapeArgs . prgFlags . ccProgram . tgtCCompiler
- cxxPath = prgPath . cxxProgram . tgtCxxCompiler
- cxxFlags = escapeArgs . prgFlags . cxxProgram . tgtCxxCompiler
- clinkFlags = escapeArgs . prgFlags . ccLinkProgram . tgtCCompilerLink
- linkSupportsNoPie = yesNo . ccLinkSupportsNoPie . tgtCCompilerLink
- cppPath = prgPath . cppProgram . tgtCPreprocessor
- cppFlags = escapeArgs . prgFlags . cppProgram . tgtCPreprocessor
- hsCppPath = prgPath . hsCppProgram . tgtHsCPreprocessor
- hsCppFlags = escapeArgs . prgFlags . hsCppProgram . tgtHsCPreprocessor
- jsCppPath = maybe "" (prgPath . jsCppProgram) . tgtJsCPreprocessor
- jsCppFlags = maybe "" (escapeArgs . prgFlags . jsCppProgram) . tgtJsCPreprocessor
- cmmCppPath = prgPath . cmmCppProgram . tgtCmmCPreprocessor
- cmmCppFlags = escapeArgs . prgFlags . cmmCppProgram . tgtCmmCPreprocessor
- cmmCppSupportsG0' = yesNo . cmmCppSupportsG0 . tgtCmmCPreprocessor
- mergeObjsPath = maybe "" (prgPath . mergeObjsProgram) . tgtMergeObjs
- mergeObjsFlags = maybe "" (escapeArgs . prgFlags . mergeObjsProgram) . tgtMergeObjs
- linkSupportsSingleModule = yesNo . ccLinkSupportsSingleModule . tgtCCompilerLink
- linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink
- linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink
- linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink
- llcPath = maybe "" prgPath . tgtLlc
- optPath = maybe "" prgPath . tgtOpt
- llvmAsPath = maybe "" prgPath . tgtLlvmAs
- llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs
- arPath = prgPath . arMkArchive . tgtAr
- arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr
- arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr
- arSupportsDashL' = yesNo . arSupportsDashL . tgtAr
- otoolPath = maybe "" prgPath . tgtOtool
- installNameToolPath = maybe "" prgPath . tgtInstallNameTool
- ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib
- mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs
isBigEndian, wordSize :: Toolchain.Target -> String
isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness
=====================================
libraries/ghc-boot/GHC/Settings/Utils.hs
=====================================
@@ -10,6 +10,8 @@ import GHC.BaseDir
import GHC.Platform.ArchOS
import System.FilePath
+import GHC.Toolchain.Target
+
maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
[(x, "")] -> Just x
@@ -36,19 +38,17 @@ type RawSettings = Map String String
-- | Read target Arch/OS from the settings
getTargetArchOS
- :: FilePath -- ^ Settings filepath (for error messages)
- -> RawSettings -- ^ Raw settings file contents
- -> Either String ArchOS
-getTargetArchOS settingsFile settings =
- ArchOS <$> readRawSetting settingsFile settings "target arch"
- <*> readRawSetting settingsFile settings "target os"
+ :: Target -- ^ The 'Target' from which to read the 'ArchOS'
+ -> ArchOS
+getTargetArchOS target = tgtArchOs target
getGlobalPackageDb :: FilePath -> RawSettings -> Either String FilePath
getGlobalPackageDb settingsFile settings = do
rel_db <- getRawSetting settingsFile settings "Relative Global Package DB"
return (dropFileName settingsFile </> rel_db)
-
+--------------------------------------------------------------------------------
+-- lib/settings
getRawSetting
:: FilePath -> RawSettings -> String -> Either String String
@@ -70,10 +70,3 @@ getRawBooleanSetting settingsFile settings key = do
"NO" -> Right False
xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs
-readRawSetting
- :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a
-readRawSetting settingsFile settings key = case Map.lookup key settings of
- Just xs -> case maybeRead xs of
- Just v -> Right v
- Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs
- Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -82,7 +82,8 @@ Library
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.6,
deepseq >= 1.4 && < 1.6,
- ghc-platform >= 0.1,
+ ghc-platform >= 0.1,
+ ghc-toolchain >= 0.1
-- reexport modules from ghc-boot-th so that packages
-- don't have to import all of ghc-boot and ghc-boot-th.
=====================================
libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs
=====================================
@@ -20,7 +20,7 @@
module GHC.Internal.ResponseFile (
getArgsWithResponseFiles,
unescapeArgs,
- escapeArgs,
+ escapeArgs, escapeArg,
expandResponse
) where
=====================================
m4/fp_settings.m4 deleted
=====================================
@@ -1,171 +0,0 @@
-dnl Note [How we configure the bundled windows toolchain]
-dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the
-dnl bundled windows toolchain, the GHC settings file must refer to the
-dnl toolchain through a path relative to $tooldir (binary distributions on
-dnl Windows should work without configure, so the paths must be relative to the
-dnl installation). However, hadrian expects the configured toolchain to use
-dnl full paths to the executable.
-dnl
-dnl This is how the bundled windows toolchain is configured, to define the
-dnl toolchain with paths to the executables, while still writing into GHC
-dnl settings the paths relative to $tooldir:
-dnl
-dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked
-dnl
-dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths
-dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc)
-dnl
-dnl * Later on, in FP_SETTINGS, we substitute occurrences of the path to the
-dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR).
-dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to
-dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir.
-dnl
-dnl * Finally, hadrian will also substitute the mingw prefix by $tooldir before writing the toolchain to the settings file (see generateSettings)
-dnl
-dnl The ghc-toolchain program isn't concerned with any of these complications:
-dnl it is passed either the full paths to the toolchain executables, or the bundled
-dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain
-dnl will, as always, output target files with full paths to the executables.
-dnl
-dnl Hadrian accounts for this as it does for the toolchain executables
-dnl configured by configure -- in fact, hadrian doesn't need to know whether
-dnl the toolchain description file was generated by configure or by
-dnl ghc-toolchain.
-
-# SUBST_TOOLDIR
-# ----------------------------------
-# $1 - the variable where to search for occurrences of the path to the
-# inplace mingw, and update by substituting said occurrences by
-# the value of $mingw_install_prefix, where the mingw toolchain will be at
-# install time
-#
-# See Note [How we configure the bundled windows toolchain]
-AC_DEFUN([SUBST_TOOLDIR],
-[
- dnl and Note [How we configure the bundled windows toolchain]
- $1=`echo "$$1" | sed 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g'`
-])
-
-# FP_SETTINGS
-# ----------------------------------
-# Set the variables used in the settings file
-AC_DEFUN([FP_SETTINGS],
-[
- SettingsUseDistroMINGW="$EnableDistroToolchain"
-
- SettingsCCompilerCommand="$CC"
- SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2"
- SettingsCxxCompilerCommand="$CXX"
- SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2"
- SettingsCPPCommand="$CPPCmd"
- SettingsCPPFlags="$CONF_CPP_OPTS_STAGE2"
- SettingsHaskellCPPCommand="$HaskellCPPCmd"
- SettingsHaskellCPPFlags="$HaskellCPPArgs"
- SettingsJavaScriptCPPCommand="$JavaScriptCPPCmd"
- SettingsJavaScriptCPPFlags="$JavaScriptCPPArgs"
- SettingsCmmCPPCommand="$CmmCPPCmd"
- SettingsCmmCPPFlags="$CmmCPPArgs"
- SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2"
- SettingsArCommand="$ArCmd"
- SettingsRanlibCommand="$RanlibCmd"
- SettingsMergeObjectsCommand="$MergeObjsCmd"
- SettingsMergeObjectsFlags="$MergeObjsArgs"
-
- AS_CASE(
- ["$CmmCPPSupportsG0"],
- [True], [SettingsCmmCPPSupportsG0=YES],
- [False], [SettingsCmmCPPSupportsG0=NO],
- [AC_MSG_ERROR(Unknown CPPSupportsG0 value $CmmCPPSupportsG0)]
- )
-
- if test -z "$WindresCmd"; then
- SettingsWindresCommand="/bin/false"
- else
- SettingsWindresCommand="$WindresCmd"
- fi
-
- # LLVM backend tools
- SettingsLlcCommand="$LlcCmd"
- SettingsOptCommand="$OptCmd"
- SettingsLlvmAsCommand="$LlvmAsCmd"
- SettingsLlvmAsFlags="$LlvmAsFlags"
-
- if test "$EnableDistroToolchain" = "YES"; then
- # If the user specified --enable-distro-toolchain then we just use the
- # executable names, not paths.
- SettingsCCompilerCommand="$(basename $SettingsCCompilerCommand)"
- SettingsHaskellCPPCommand="$(basename $SettingsHaskellCPPCommand)"
- SettingsCmmCPPCommand="$(basename $SettingsCmmCPPCommand)"
- SettingsJavaScriptCPPCommand="$(basename $SettingsJavaScriptCPPCommand)"
- SettingsLdCommand="$(basename $SettingsLdCommand)"
- SettingsMergeObjectsCommand="$(basename $SettingsMergeObjectsCommand)"
- SettingsArCommand="$(basename $SettingsArCommand)"
- SettingsWindresCommand="$(basename $SettingsWindresCommand)"
- SettingsLlcCommand="$(basename $SettingsLlcCommand)"
- SettingsOptCommand="$(basename $SettingsOptCommand)"
- SettingsLlvmAsCommand="$(basename $SettingsLlvmAsCommand)"
- fi
-
- if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then
- # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN.
- # We need to issue a substitution to use $tooldir,
- # See Note [tooldir: How GHC finds mingw on Windows]
- SUBST_TOOLDIR([SettingsCCompilerCommand])
- SUBST_TOOLDIR([SettingsCCompilerFlags])
- SUBST_TOOLDIR([SettingsCxxCompilerCommand])
- SUBST_TOOLDIR([SettingsCxxCompilerFlags])
- SUBST_TOOLDIR([SettingsCCompilerLinkFlags])
- SUBST_TOOLDIR([SettingsCPPCommand])
- SUBST_TOOLDIR([SettingsCPPFlags])
- SUBST_TOOLDIR([SettingsHaskellCPPCommand])
- SUBST_TOOLDIR([SettingsHaskellCPPFlags])
- SUBST_TOOLDIR([SettingsCmmCPPCommand])
- SUBST_TOOLDIR([SettingsCmmCPPFlags])
- SUBST_TOOLDIR([SettingsJavaScriptCPPCommand])
- SUBST_TOOLDIR([SettingsJavaScriptCPPFlags])
- SUBST_TOOLDIR([SettingsMergeObjectsCommand])
- SUBST_TOOLDIR([SettingsMergeObjectsFlags])
- SUBST_TOOLDIR([SettingsArCommand])
- SUBST_TOOLDIR([SettingsRanlibCommand])
- SUBST_TOOLDIR([SettingsWindresCommand])
- SUBST_TOOLDIR([SettingsLlcCommand])
- SUBST_TOOLDIR([SettingsOptCommand])
- SUBST_TOOLDIR([SettingsLlvmAsCommand])
- SUBST_TOOLDIR([SettingsLlvmAsFlags])
- fi
-
- # Mac-only tools
- SettingsOtoolCommand="$OtoolCmd"
- SettingsInstallNameToolCommand="$InstallNameToolCmd"
-
- SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE"
-
- AC_SUBST(SettingsCCompilerCommand)
- AC_SUBST(SettingsCxxCompilerCommand)
- AC_SUBST(SettingsCPPCommand)
- AC_SUBST(SettingsCPPFlags)
- AC_SUBST(SettingsHaskellCPPCommand)
- AC_SUBST(SettingsHaskellCPPFlags)
- AC_SUBST(SettingsCmmCPPCommand)
- AC_SUBST(SettingsCmmCPPFlags)
- AC_SUBST(SettingsCmmCPPSupportsG0)
- AC_SUBST(SettingsJavaScriptCPPCommand)
- AC_SUBST(SettingsJavaScriptCPPFlags)
- AC_SUBST(SettingsCCompilerFlags)
- AC_SUBST(SettingsCxxCompilerFlags)
- AC_SUBST(SettingsCCompilerLinkFlags)
- AC_SUBST(SettingsCCompilerSupportsNoPie)
- AC_SUBST(SettingsMergeObjectsCommand)
- AC_SUBST(SettingsMergeObjectsFlags)
- AC_SUBST(SettingsArCommand)
- AC_SUBST(SettingsRanlibCommand)
- AC_SUBST(SettingsOtoolCommand)
- AC_SUBST(SettingsInstallNameToolCommand)
- AC_SUBST(SettingsWindresCommand)
- AC_SUBST(SettingsLlcCommand)
- AC_SUBST(SettingsOptCommand)
- AC_SUBST(SettingsLlvmAsCommand)
- AC_SUBST(SettingsLlvmAsFlags)
- AC_SUBST(SettingsUseDistroMINGW)
-])
=====================================
m4/fp_setup_windows_toolchain.m4
=====================================
@@ -77,6 +77,7 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[
# $2 the location that the windows toolchain will be installed in relative to the libdir
AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
+ # TODO: UPDATE COMMENT
# N.B. The parameters which get plopped in the `settings` file used by the
# resulting compiler are computed in `FP_SETTINGS`. Specifically, we use
# $$topdir-relative paths instead of fullpaths to the toolchain, by replacing
=====================================
m4/subst_tooldir.m4
=====================================
@@ -0,0 +1,45 @@
+dnl Note [How we configure the bundled windows toolchain]
+dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the
+dnl bundled windows toolchain, the GHC settings file must refer to the
+dnl toolchain through a path relative to $tooldir (binary distributions on
+dnl Windows should work without configure, so the paths must be relative to the
+dnl installation). However, hadrian expects the configured toolchain to use
+dnl full paths to the executable.
+dnl
+dnl This is how the bundled windows toolchain is configured, to define the
+dnl toolchain with paths to the executables, while still writing into GHC
+dnl settings the paths relative to $tooldir:
+dnl
+dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked
+dnl
+dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths
+dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc)
+dnl
+dnl * Later on, at the end of distrib/configure.ac, we substitute occurrences of the path to the
+dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR).
+dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to
+dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir.
+dnl
+dnl The ghc-toolchain program isn't concerned with any of these complications:
+dnl it is passed either the full paths to the toolchain executables, or the bundled
+dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain
+dnl will, as always, output target files with full paths to the executables.
+dnl
+dnl Hadrian accounts for this as it does for the toolchain executables
+dnl configured by configure -- in fact, hadrian doesn't need to know whether
+dnl the toolchain description file was generated by configure or by
+dnl ghc-toolchain.
+
+# SUBST_TOOLDIR
+# ----------------------------------
+# $1 - the filepath where to search for occurrences of the path to the
+# inplace mingw, and update by substituting said occurrences by
+# the value of $mingw_install_prefix, where the mingw toolchain will be at
+# install time
+#
+# See Note [How we configure the bundled windows toolchain]
+AC_DEFUN([SUBST_TOOLDIR],
+[
+ sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g'
+])
=====================================
mk/hsc2hs.in
=====================================
@@ -1,6 +1,6 @@
-HSC2HS_C="@SettingsCCompilerFlags@"
+HSC2HS_C="@CONF_CC_OPTS_STAGE2@"
-HSC2HS_L="@SettingsCCompilerLinkFlags@"
+HSC2HS_L="@CONF_GCC_LINKER_OPTS_STAGE2@"
tflag="--template=$libdir/template-hsc.h"
Iflag="-I$includedir/include/"
=====================================
testsuite/tests/ghc-api/T20757.hs
=====================================
@@ -3,4 +3,4 @@ module Main where
import GHC.SysTools.BaseDir
main :: IO ()
-main = findToolDir False "/" >>= print
+main = findToolDir "/" >>= print
=====================================
testsuite/tests/ghc-api/settings-escape/T24265.hs
=====================================
@@ -16,6 +16,13 @@ import System.Environment
import System.IO (hPutStrLn, stderr)
import System.Exit (exitWith, ExitCode(ExitFailure))
+import GHC.Toolchain
+import GHC.Toolchain.Program
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Cpp
+import GHC.Toolchain.Tools.Cxx
+import GHC.Toolchain.Lens
+
-- Precondition: this test case must be executed in a directory with a space.
--
-- First we get the current settings file and amend it with extra arguments that we *know*
@@ -30,35 +37,29 @@ main :: IO ()
main = do
libdir:_args <- getArgs
- (rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do
+ (rawSettingOpts, rawTargetOpts, originalSettings) <- runGhc (Just libdir) $ do
dflags <- hsc_dflags <$> getSession
- pure (rawSettings dflags, settings dflags)
+ pure (rawSettings dflags, rawTarget dflags, settings dflags)
top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces"
- let argsWithSpaces = "\"-some option\" -some\\ other"
- numberOfExtraArgs = length $ unescapeArgs argsWithSpaces
- -- These are all options that can have multiple 'String' or 'Option' values.
- -- We explicitly do not add 'C compiler link flags' here, as 'initSettings'
- -- already adds the options of "C compiler flags" to this config field.
- multipleArguments = Set.fromList
- [ "Haskell CPP flags"
- , "JavaScript CPP flags"
- , "C-- CPP flags"
- , "C compiler flags"
- , "C++ compiler flags"
- , "CPP flags"
- , "Merge objects flags"
+ let argsWithSpaces l = over l (++["-some option", "-some\\ other"])
+ numberOfExtraArgs = 2
+ -- Test it on a handfull of list of flags
+ multipleArguments =
+ [ _tgtHsCpp % _hsCppProg % _prgFlags -- "Haskell CPP flags"
+ , _tgtCC % _ccProgram % _prgFlags -- "C compiler flags"
+ , _tgtCxx % _cxxProgram % _prgFlags -- "C++ compiler flags"
+ , _tgtCpp % _cppProg % _prgFlags -- "CPP flags"
]
- let rawSettingOptsWithExtraArgs =
- map (\(name, args) -> if Set.member name multipleArguments
- then (name, args ++ " " ++ argsWithSpaces)
- else (name, args)) rawSettingOpts
+ targetWithExtraArgs = foldr argsWithSpaces rawTargetOpts multipleArguments
-- write out the modified settings. We try to keep it legible
writeFile (top_dir ++ "/settings") $
- "[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]"
+ "[" ++ (intercalate "\n," (map show rawSettingOpts)) ++ "]"
+ writeFile (top_dir ++ "/targets/default.target") $
+ show targetWithExtraArgs
settingsm <- runExceptT $ initSettings top_dir
@@ -113,12 +114,6 @@ main = do
-- Setting 'Haskell CPP flags' contains '$topdir' reference.
-- Resolving those while containing spaces, should not introduce more options.
recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings)
- -- Setting 'JavaScript CPP flags' contains '$topdir' reference.
- -- Resolving those while containing spaces, should not introduce more options.
- recordSetting "JavaScript CPP flags" (map showOpt . snd . toolSettings_pgm_JSP . sToolSettings)
- -- Setting 'C-- CPP flags' contains '$topdir' reference.
- -- Resolving those while containing spaces, should not introduce more options.
- recordSetting "C-- CPP flags" (map showOpt . snd . toolSettings_pgm_CmmP . sToolSettings)
-- Setting 'C compiler flags' contains strings with spaces.
-- GHC should not split these by word.
recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings)
@@ -133,10 +128,6 @@ main = do
-- Setting 'CPP flags' contains strings with spaces.
-- GHC should not split these by word.
recordSetting "CPP flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings)
- -- Setting 'Merge objects flags' contains strings with spaces.
- -- GHC should not split these by word.
- -- If 'Nothing', ignore this test, otherwise the same assertion holds as before.
- recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings)
-- Setting 'C compiler command' contains '$topdir' reference.
-- Spaces in the final filepath should not be escaped.
recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings)
=====================================
testsuite/tests/ghc-api/settings-escape/T24265.stderr
=====================================
@@ -1,9 +1,5 @@
=== 'Haskell CPP flags' contains 2 new entries: True
Contains spaces: True
-=== 'JavaScript CPP flags' contains 2 new entries: True
- Contains spaces: True
-=== 'C-- CPP flags' contains 2 new entries: True
- Contains spaces: True
=== 'C compiler flags' contains 2 new entries: True
Contains spaces: True
=== 'C compiler link flags' contains 2 new entries: True
@@ -12,5 +8,4 @@
Contains spaces: True
=== 'CPP flags' contains 2 new entries: True
Contains spaces: True
-=== 'Merge objects flags' contains expected entries: True
=== FilePath 'C compiler' contains escaped spaces: False
=====================================
testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep
=====================================
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -96,6 +96,8 @@ import System.Posix hiding (fdToHandle)
import qualified System.Info(os)
#endif
+import GHC.Toolchain.Target
+
-- | Short-circuit 'any' with a \"monadic predicate\".
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
@@ -583,9 +585,20 @@ readFromSettingsFile settingsFile f = do
-- It's excusable to not have a settings file (for now at
-- least) but completely inexcusable to have a malformed one.
Nothing -> Left $ "Can't parse settings file " ++ show settingsFile
- case f settingsFile mySettings of
- Right archOS -> Right archOS
- Left e -> Left e
+ f settingsFile mySettings
+
+readFromTargetFile :: FilePath
+ -> (Target -> b)
+ -> IO (Either String b)
+readFromTargetFile targetFile f = do
+ targetStr <- readFile targetFile
+ pure $ do
+ target <- case maybeReadFuzzy targetStr of
+ Just t -> Right t
+ -- It's excusable to not have a settings file (for now at
+ -- least) but completely inexcusable to have a malformed one.
+ Nothing -> Left $ "Can't parse .target file " ++ show targetFile
+ Right (f target)
getPkgDatabases :: Verbosity
-> GhcPkg.DbOpenMode mode DbModifySelector
@@ -618,6 +631,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
Nothing -> die err_msg
Just dir -> do
-- Look for where it is given in the settings file, if marked there.
+ -- See Note [Settings file] about this file, and why we need GHC to share it with us.
let settingsFile = dir </> "settings"
exists_settings_file <- doesFileExist settingsFile
erel_db <-
@@ -652,16 +666,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
case [ f | FlagUserConfig f <- my_flags ] of
_ | no_user_db -> return Nothing
[] -> do
- -- See Note [Settings file] about this file, and why we need GHC to share it with us.
- let settingsFile = top_dir </> "settings"
- exists_settings_file <- doesFileExist settingsFile
+ let targetFile = top_dir </> "targets" </> "default.target"
+ exists_settings_file <- doesFileExist targetFile
targetArchOS <- case exists_settings_file of
False -> do
- warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
+ warn $ "WARNING: target file doesn't exist " ++ show targetFile
warn "cannot know target platform so guessing target == host (native compiler)."
pure hostPlatformArchOS
True ->
- readFromSettingsFile settingsFile getTargetArchOS >>= \case
+ readFromTargetFile targetFile getTargetArchOS >>= \case
Right v -> pure v
Left e -> die e
=====================================
utils/ghc-pkg/ghc-pkg.cabal.in
=====================================
@@ -29,6 +29,7 @@ Executable ghc-pkg
Cabal-syntax,
binary,
ghc-boot,
+ ghc-toolchain,
bytestring
if !os(windows)
Build-Depends: unix
=====================================
utils/ghc-toolchain/exe/Main.hs
=====================================
@@ -534,4 +534,3 @@ mkTarget opts = do
}
return t
---- ROMES:TODO: fp_settings.m4 in general which I don't think was ported completely (e.g. the basenames and windows llvm-XX and such)
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
=====================================
@@ -7,6 +7,9 @@ module GHC.Toolchain.Target
, WordSize(..), wordSize2Bytes
+ -- ** Lenses
+ , _tgtCC, _tgtCxx, _tgtCpp, _tgtHsCpp
+
-- * Re-exports
, ByteOrder(..)
) where
@@ -137,3 +140,29 @@ instance Show Target where
, ", tgtInstallNameTool = " ++ show tgtInstallNameTool
, "}"
]
+
+--------------------------------------------------------------------------------
+-- Lenses
+--------------------------------------------------------------------------------
+
+_tgtCC :: Lens Target Cc
+_tgtCC = Lens tgtCCompiler (\x o -> o {tgtCCompiler = x})
+
+_tgtCxx :: Lens Target Cxx
+_tgtCxx = Lens tgtCxxCompiler (\x o -> o {tgtCxxCompiler = x})
+
+_tgtCpp :: Lens Target Cpp
+_tgtCpp = Lens tgtCPreprocessor (\x o -> o {tgtCPreprocessor = x})
+
+_tgtHsCpp :: Lens Target HsCpp
+_tgtHsCpp = Lens tgtHsCPreprocessor (\x o -> o {tgtHsCPreprocessor = x})
+
+_tgtJsCpp :: Lens Target (Maybe JsCpp)
+_tgtJsCpp = Lens tgtJsCPreprocessor (\x o -> o {tgtJsCPreprocessor = x})
+
+_tgtCmmCpp :: Lens Target CmmCpp
+_tgtCmmCpp = Lens tgtCmmCPreprocessor (\x o -> o {tgtCmmCPreprocessor = x})
+
+_tgtMergeObjs :: Lens Target (Maybe MergeObjs)
+_tgtMergeObjs = Lens tgtMergeObjs (\x o -> o {tgtMergeObjs = x})
+
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
=====================================
@@ -5,6 +5,9 @@ module GHC.Toolchain.Tools.Cpp
, Cpp(..), findCpp
, JsCpp(..), findJsCpp
, CmmCpp(..), findCmmCpp
+
+ -- * Lenses
+ , _cppProg, _hsCppProg, _jsCppProg, _cmmCppProg
) where
import Control.Monad
@@ -188,3 +191,18 @@ findCpp progOpt cc = checking "for C preprocessor" $ do
let cppProgram = addFlagIfNew "-E" cpp2
return Cpp{cppProgram}
+--------------------------------------------------------------------------------
+-- Lenses
+--------------------------------------------------------------------------------
+
+_cppProg :: Lens Cpp Program
+_cppProg = Lens cppProgram (\x o -> o{cppProgram = x})
+
+_hsCppProg :: Lens HsCpp Program
+_hsCppProg = Lens hsCppProgram (\x o -> o{hsCppProgram = x})
+
+_jsCppProg :: Lens JsCpp Program
+_jsCppProg = Lens jsCppProgram (\x o -> o{jsCppProgram = x})
+
+_cmmCppProg :: Lens CmmCpp Program
+_cmmCppProg = Lens cmmCppProgram (\x o -> o{cmmCppProgram = x})
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs
=====================================
@@ -4,7 +4,7 @@ module GHC.Toolchain.Tools.Cxx
( Cxx(..)
, findCxx
-- * Helpful utilities
- , compileCxx
+ , compileCxx, _cxxProgram
) where
import System.FilePath
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5f031f3ba575ea14235b13865c19c7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5f031f3ba575ea14235b13865c19c7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/14554-wasm-fix] Deleted 1 commit: ghc-toolchain: Move TgtHasLibm to per-Target file
by Cheng Shao (＠TerrorJack) 24 Aug '25
by Cheng Shao (＠TerrorJack) 24 Aug '25
24 Aug '25
Cheng Shao pushed to branch wip/14554-wasm-fix at Glasgow Haskell Compiler / GHC
WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below.
Deleted commits:
dbf776cc by Rodrigo Mesquita at 2025-08-23T19:21:31+02:00
ghc-toolchain: Move TgtHasLibm to per-Target file
TargetHasLibm is now part of the per-target configuration
Towards #26227
- - - - -
11 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings/IO.hs
- hadrian/bindist/Makefile
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/cfg/system.config.in
- hadrian/src/Rules/Generate.hs
- m4/prep_target_file.m4
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3499,6 +3499,7 @@ compilerInfo dflags
("target word size", query $ show . wordSize2Bytes . tgtWordSize),
("target word big endian", queryBool $ (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness),
("target has GNU nonexec stack", queryBool tgtSupportsGnuNonexecStack),
+ ("target has libm", queryBool tgtHasLibm),
("target has .ident directive", queryBool tgtSupportsIdentDirective),
("target has subsections via symbols", queryBool tgtSupportsSubsectionsViaSymbols),
("Unregisterised", queryBool tgtUnregisterised),
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -97,10 +97,6 @@ initSettings top_dir = do
getTool :: (Target -> Program) -> (String, [String])
getTool key = (getToolPath key, getToolFlags key)
- -- See Note [Settings file] for a little more about this file. We're
- -- just partially applying those functions and throwing 'Left's; they're
- -- written in a very portable style to keep ghc-boot light.
- targetHasLibm <- getBooleanSetting "target has libm"
let
(cc_prog, cc_args0) = getTool (ccProgram . tgtCCompiler)
(cxx_prog, cxx_args) = getTool (cxxProgram . tgtCxxCompiler)
@@ -109,7 +105,7 @@ initSettings top_dir = do
(js_cpp_prog, js_cpp_args) = getTool (maybe (Program "" []) jsCppProgram . tgtJsCPreprocessor)
(cmmCpp_prog, cmmCpp_args) = getTool (cmmCppProgram . tgtCmmCPreprocessor)
- platform = getTargetPlatform targetHasLibm target
+ platform = getTargetPlatform target
unreg_cc_args = if platformUnregisterised platform
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
@@ -242,8 +238,8 @@ initSettings top_dir = do
, sRawTarget = target
}
-getTargetPlatform :: Bool {-^ Does target have libm -} -> Target -> Platform
-getTargetPlatform targetHasLibm Target{..} = Platform
+getTargetPlatform :: Target -> Platform
+getTargetPlatform Target{..} = Platform
{ platformArchOS = tgtArchOs
, platformWordSize = case tgtWordSize of WS4 -> PW4
WS8 -> PW8
@@ -255,6 +251,6 @@ getTargetPlatform targetHasLibm Target{..} = Platform
, platformIsCrossCompiling = not tgtLocallyExecutable
, platformLeadingUnderscore = tgtSymbolsHaveLeadingUnderscore
, platformTablesNextToCode = tgtTablesNextToCode
- , platformHasLibm = targetHasLibm
+ , platformHasLibm = tgtHasLibm
, platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit
}
=====================================
hadrian/bindist/Makefile
=====================================
@@ -85,8 +85,7 @@ WrapperBinsDir=${bindir}
# N.B. this is duplicated from includes/ghc.mk.
lib/settings : config.mk
@rm -f $@
- @echo '[("target has libm", "$(TargetHasLibm)")' >> $@
- @echo ',("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@
+ @echo '[("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@
@echo ',("target RTS linker only supports shared libraries", "$(TargetRTSLinkerOnlySupportsSharedLibs)")' >> $@
@echo ',("Use interpreter", "$(GhcWithInterpreter)")' >> $@
@echo ',("Support SMP", "$(GhcWithSMP)")' >> $@
=====================================
hadrian/cfg/default.host.target.in
=====================================
@@ -12,6 +12,7 @@ Target
, tgtUnregisterised = False
, tgtTablesNextToCode = True
, tgtUseLibffiForAdjustors = True
+, tgtHasLibm = True
, tgtCCompiler = Cc {ccProgram = Program {prgPath = "@CC_STAGE0@", prgFlags = @CONF_CC_OPTS_STAGE0List@}}
, tgtCxxCompiler = Cxx {cxxProgram = Program {prgPath = "@CC_STAGE0@", prgFlags = @CONF_CXX_OPTS_STAGE0List@}}
, tgtCPreprocessor = Cpp {cppProgram = Program {prgPath = "@CPPCmd_STAGE0@", prgFlags = @CONF_CPP_OPTS_STAGE0List@}}
=====================================
hadrian/cfg/default.target.in
=====================================
@@ -12,6 +12,7 @@ Target
, tgtUnregisterised = @UnregisterisedBool@
, tgtTablesNextToCode = @TablesNextToCodeBool@
, tgtUseLibffiForAdjustors = @UseLibffiForAdjustorsBool@
+, tgtHasLibm = @TargetHasLibmBool@
, tgtCCompiler = Cc {ccProgram = Program {prgPath = "@CC@", prgFlags = @CONF_CC_OPTS_STAGE2List@}}
, tgtCxxCompiler = Cxx {cxxProgram = Program {prgPath = "@CXX@", prgFlags = @CONF_CXX_OPTS_STAGE2List@}}
, tgtCPreprocessor = Cpp {cppProgram = Program {prgPath = "@CPPCmd@", prgFlags = @CONF_CPP_OPTS_STAGE2List@}}
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -81,8 +81,6 @@ project-git-commit-id = @ProjectGitCommitId@
# See Note [tooldir: How GHC finds mingw on Windows]
settings-use-distro-mingw = @EnableDistroToolchain@
-target-has-libm = @TargetHasLibm@
-
# Include and library directories:
#=================================
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -427,7 +427,7 @@ bindistRules = do
, interpolateSetting "ProjectVersion" ProjectVersion
, interpolateVar "EnableDistroToolchain" $ lookupSystemConfig "settings-use-distro-mingw"
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
- , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm"
+ , interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
@@ -484,7 +484,6 @@ generateSettings settingsFile = do
settings <- traverse sequence $
[ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
- , ("target has libm", expr $ lookupSystemConfig "target-has-libm")
, ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs)
, ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage))
, ("Support SMP", expr $ yesNo <$> targetSupportsSMP)
=====================================
m4/prep_target_file.m4
=====================================
@@ -157,6 +157,7 @@ AC_DEFUN([PREP_TARGET_FILE],[
PREP_BOOLEAN([Unregisterised])
PREP_BOOLEAN([TablesNextToCode])
PREP_BOOLEAN([UseLibffiForAdjustors])
+ PREP_BOOLEAN([TargetHasLibm])
PREP_BOOLEAN([ArIsGNUAr])
PREP_BOOLEAN([ArNeedsRanLib])
PREP_NOT_BOOLEAN([CrossCompiling])
=====================================
utils/ghc-toolchain/exe/Main.hs
=====================================
@@ -486,6 +486,7 @@ mkTarget opts = do
tgtSupportsSubsectionsViaSymbols <- checkSubsectionsViaSymbols archOs cc
tgtSupportsIdentDirective <- checkIdentDirective cc
tgtSupportsGnuNonexecStack <- checkGnuNonexecStack archOs cc
+ tgtHasLibm <- checkTargetHasLibm cc
-- code generator configuration
tgtUnregisterised <- determineUnregisterised archOs (optUnregisterised opts)
@@ -526,6 +527,7 @@ mkTarget opts = do
, tgtUnregisterised
, tgtTablesNextToCode
, tgtUseLibffiForAdjustors = tgtUseLibffi
+ , tgtHasLibm
, tgtSymbolsHaveLeadingUnderscore
, tgtSupportsSubsectionsViaSymbols
, tgtSupportsIdentDirective
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Toolchain.PlatformDetails
, checkSubsectionsViaSymbols
, checkIdentDirective
, checkGnuNonexecStack
+ , checkTargetHasLibm
) where
import Data.List (isInfixOf)
@@ -112,8 +113,6 @@ checkEndianness__BYTE_ORDER__ cc = checking "endianness (__BYTE_ORDER__)" $ do
, "#endif"
]
-
-
checkLeadingUnderscore :: Cc -> Nm -> M Bool
checkLeadingUnderscore cc nm = checking ctxt $ withTempDir $ \dir -> do
let test_o = dir </> "test.o"
@@ -156,6 +155,21 @@ checkGnuNonexecStack archOs =
, asmStmt ".section .text"
]
+checkTargetHasLibm :: Cc -> M Bool
+checkTargetHasLibm cc0 = testCompile "whether target has libm" prog cc
+ where
+ cc = cc0 & _ccProgram % _prgFlags %++ "-lm"
+ prog = unlines
+ [ "char atan (void);"
+ , "int"
+ , "main (void)"
+ , "{"
+ , "return atan ();"
+ , " ;"
+ , " return 0;"
+ , "}"
+ ]
+
asmStmt :: String -> String
asmStmt s = "__asm__(\"" ++ foldMap escape s ++ "\");"
where
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
=====================================
@@ -57,6 +57,10 @@ data Target = Target
, tgtUseLibffiForAdjustors :: Bool
-- ^ We need to know whether or not to include libffi headers, and generate additional code for it
+ -- Target support
+ , tgtHasLibm :: Bool
+ -- ^ Does this target have a libm library that should always be linked against?
+
-- C toolchain
, tgtCCompiler :: Cc
, tgtCxxCompiler :: Cxx
@@ -121,6 +125,7 @@ instance Show Target where
, ", tgtUnregisterised = " ++ show tgtUnregisterised
, ", tgtTablesNextToCode = " ++ show tgtTablesNextToCode
, ", tgtUseLibffiForAdjustors = " ++ show tgtUseLibffiForAdjustors
+ , ", tgtHasLibm = " ++ show tgtHasLibm
, ", tgtCCompiler = " ++ show tgtCCompiler
, ", tgtCxxCompiler = " ++ show tgtCxxCompiler
, ", tgtCPreprocessor = " ++ show tgtCPreprocessor
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dbf776ccce0de1fd1755f240eb8c0f1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dbf776ccce0de1fd1755f240eb8c0f1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 6 commits: Serialize wired-in names as external names when creating HIE files
by Hannes Siebenhandl (＠fendor) 24 Aug '25
by Hannes Siebenhandl (＠fendor) 24 Aug '25
24 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00
Serialize wired-in names as external names when creating HIE files
Note that the domain of de-serialized names stays the same.
Specifically, for known-key names, before `lookupKnownKeyName` was used,
while now this is handled by `lookupOrigNameCache` which captures the
same range provided that the OrigNameCache has been initialized with
`knownKeyNames` (which is the case by default).
(fixes #26238)
- - - - -
6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00
compiler: fix closure C type in SPT init code
This patch fixes the closure C type in SPT init code to StgClosure,
instead of the previously incorrect StgPtr. Having an incorrect C type
makes SPT init code not compatible with other foreign stub generation
logic, which may also emit their own extern declarations for the same
closure symbols and thus will clash with the incorrect prototypes in
SPT init code.
- - - - -
f8c4515f by fendor at 2025-08-24T16:54:02+02:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
54da63a9 by fendor at 2025-08-24T17:29:25+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
354594ac by fendor at 2025-08-24T17:29:42+02:00
Remove stg_decodeStackzh
- - - - -
a7ea9489 by fendor at 2025-08-24T17:29:43+02:00
Remove ghcHeap from list of toolTargets
- - - - -
58 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/ghc.cabal.in
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/ghci.cabal.in
- 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
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dcb353813ffff863e1b8f209921a68…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dcb353813ffff863e1b8f209921a68…
You're receiving this email because of your account on gitlab.haskell.org.
1
0