16 Jul '25
Alan Zimmerman pushed new branch wip/az/exactprint-updates at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/exactprint-updates
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mapMaybe-for-nonEmpty] 16 commits: Bump win32-tarballs to v0.9
by Bodigrim (＠Bodigrim) 16 Jul '25
by Bodigrim (＠Bodigrim) 16 Jul '25
16 Jul '25
Bodigrim pushed to branch wip/mapMaybe-for-nonEmpty at Glasgow Haskell Compiler / GHC
Commits:
73082769 by Ben Gamari at 2025-07-15T16:56:38-04:00
Bump win32-tarballs to v0.9
- - - - -
3b63b254 by Ben Gamari at 2025-07-15T16:56:39-04:00
rts/LoadArchive: Handle null terminated string tables
As of `llvm-ar` now emits filename tables terminated with null
characters instead of the usual POSIX `/\n` sequence.
Fixes #26150.
- - - - -
195f6527 by Tamar Christina at 2025-07-15T16:56:39-04:00
rts: rename label so name doesn't conflict with param
- - - - -
63373b95 by Tamar Christina at 2025-07-15T16:56:39-04:00
rts: Handle API set symbol versioning conflicts
- - - - -
48e9aa3e by Tamar Christina at 2025-07-15T16:56:39-04:00
rts: Mark API set symbols as HIDDEN and correct symbol type
- - - - -
959e827a by Tamar Christina at 2025-07-15T16:56:39-04:00
rts: Implement WEAK EXTERNAL undef redirection by target symbol name
- - - - -
65f19293 by Ben Gamari at 2025-07-15T16:56:39-04:00
rts/LoadArchive: Handle string table entries terminated with /
llvm-ar appears to terminate string table entries with `/\n` [1]. This
matters in the case of thin archives, since the filename is used. In the
past this worked since `llvm-ar` would produce archives with "small"
filenames when possible. However, now it appears to always use the
string table.
[1] https://github.com/llvm/llvm-project/blob/bfb686bb5ba503e9386dc899e1ebbe248…
- - - - -
9cbb3ef5 by Ben Gamari at 2025-07-15T16:56:39-04:00
testsuite: Mark T12497 as fixed
Thanks to the LLVM toolchain update.
Closes #22694.
- - - - -
2854407e by Ben Gamari at 2025-07-15T16:56:39-04:00
testsuite: Accept new output of T11223_link_order_a_b_2_fail on Windows
The archive member number changed due to the fact that llvm-ar now uses a
string table.
- - - - -
28439593 by Ben Gamari at 2025-07-15T16:56:39-04:00
rts/linker/PEi386: Implement IMAGE_REL_AMD64_SECREL
This appears to now be used by libc++ as distributed by msys2.
- - - - -
2b053755 by Tamar Christina at 2025-07-15T16:56:39-04:00
rts: Cleanup merge resolution residue in lookupSymbolInDLL_PEi386 and make safe without dependent
- - - - -
e8acd2e7 by Wen Kokke at 2025-07-16T08:37:04-04:00
Remove the `profile_id` parameter from various RTS functions.
Various RTS functions took a `profile_id` parameter, intended to be used to
distinguish parallel heap profile breakdowns (e.g., `-hT` and `-hi`). However,
this feature was never implemented and the `profile_id` parameter was set to 0
throughout the RTS. This commit removes the parameter but leaves the hardcoded
profile ID in the functions that emit the encoded eventlog events as to not
change the protocol.
The affected functions are `traceHeapProfBegin`, `postHeapProfBegin`,
`traceHeapProfSampleString`, `postHeapProfSampleString`,
`traceHeapProfSampleCostCentre`, and `postHeapProfSampleCostCentre`.
- - - - -
76d392a2 by Wen Kokke at 2025-07-16T08:37:04-04:00
Make `traceHeapProfBegin` an init event.
- - - - -
bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00
NCG/LA64: Support finer-grained DBAR hints
For LA664 and newer uarchs, they have made finer granularity hints
available:
Bit4: ordering or completion (0: completion, 1: ordering)
Bit3: barrier for previous read (0: true, 1: false)
Bit2: barrier for previous write (0: true, 1: false)
Bit1: barrier for succeeding read (0: true, 1: false)
Bit0: barrier for succeeding write (0: true, 1: false)
And not affect the existing models because other hints are treated
as 'dbar 0' there.
- - - - -
7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00
Disable -fprof-late-overloaded-calls for join points.
Currently GHC considers cost centres as destructive to
join contexts. Or in other words this is not considered valid:
join f x = ...
in
... -> scc<tick> jmp
This makes the functionality of `-fprof-late-overloaded-calls` not feasible
for join points in general. We used to try to work around this by putting the
ticks on the rhs of the join point rather than around the jump. However beyond
the loss of accuracy this was broken for recursive join points as we ended up
with something like:
rec-join f x = scc<tick> ... jmp f x
Which similarly is not valid as the tick once again destroys the tail call.
One might think we could limit ourselves to non-recursive tail calls and do
something clever like:
join f x = scc<tick> ...
in ... jmp f x
And sometimes this works! But sometimes the full rhs would look something like:
join g x = ....
join f x = scc<tick> ... -> jmp g x
Which, would again no longer be valid. I believe in the long run we can make
cost centre ticks non-destructive to join points. Or we could keep track of
where we are/are not allowed to insert a cost centre. But in the short term I will
simply disable the annotation of join calls under this flag.
- - - - -
547be38f by Andrew Lelechenko at 2025-07-16T23:07:34+01:00
Add Data.List.NonEmpty.mapMaybe
As per https://github.com/haskell/core-libraries-committee/issues/337
- - - - -
23 changed files:
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- docs/users_guide/profiling.rst
- libraries/base/changelog.md
- libraries/base/src/Data/List/NonEmpty.hs
- mk/get-win32-tarballs.py
- rts/ProfHeap.c
- rts/RetainerSet.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- rts/linker/LoadArchive.c
- rts/linker/PEi386.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
- testsuite/tests/rts/all.T
- testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32
- testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -1910,13 +1910,12 @@ genCCall target dest_regs arg_regs = do
MO_W64X2_Max -> unsupported mop
-- Memory Ordering
- -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.
- -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;
- -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.
-
- MO_AcquireFence -> pure (unitOL (DBAR Hint0))
- MO_ReleaseFence -> pure (unitOL (DBAR Hint0))
- MO_SeqCstFence -> pure (unitOL (DBAR Hint0))
+ -- Support finer-grained DBAR hints for LA664 and newer uarchs.
+ -- These are treated as DBAR 0 on older uarchs, so we can start
+ -- to unconditionally emit the new hints right away.
+ MO_AcquireFence -> pure (unitOL (DBAR HintAcquire))
+ MO_ReleaseFence -> pure (unitOL (DBAR HintRelease))
+ MO_SeqCstFence -> pure (unitOL (DBAR HintSeqcst))
MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)
-- Prefetch
@@ -1954,12 +1953,11 @@ genCCall target dest_regs arg_regs = do
MemOrderAcquire -> toOL [
ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR Hint0
+ DBAR HintAcquire
]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR Hint0),
- LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),
- DBAR Hint0
+ MemOrderSeqCst -> toOL [
+ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
+ DBAR HintSeqcst
]
_ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
dst = getRegisterReg platform (CmmLocal dst_reg)
@@ -1974,15 +1972,9 @@ genCCall target dest_regs arg_regs = do
(val, fmt_val, code_val) <- getSomeReg val_reg
let instrs = case ord of
MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))
- MemOrderRelease -> toOL [
- ann moDescr (DBAR Hint0),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR Hint0),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p),
- DBAR Hint0
- ]
+ -- implement with AMSWAPDB
+ MemOrderRelease -> unitOL $ ann moDescr (AMSWAPDB fmt_val (OpReg w zeroReg) (OpReg w val) (OpReg w p))
+ MemOrderSeqCst -> unitOL $ ann moDescr (AMSWAPDB fmt_val (OpReg w zeroReg) (OpReg w val) (OpReg w p))
_ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
moDescr = (text . show) mo
code =
=====================================
compiler/GHC/CmmToAsm/LA64/Instr.hs
=====================================
@@ -169,6 +169,7 @@ regUsageOfInstr platform instr = case instr of
-- LDCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- STCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- 7. Atomic Memory Access Instructions --------------------------------------
+ AMSWAPDB _ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- 8. Barrier Instructions ---------------------------------------------------
DBAR _hint -> usage ([], [])
IBAR _hint -> usage ([], [])
@@ -343,13 +344,13 @@ patchRegsOfInstr instr env = case instr of
STX f o1 o2 -> STX f (patchOp o1) (patchOp o2)
LDPTR f o1 o2 -> LDPTR f (patchOp o1) (patchOp o2)
STPTR f o1 o2 -> STPTR f (patchOp o1) (patchOp o2)
- PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2)
+ PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2)
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- LDCOND o1 o2 o3 -> LDCOND (patchOp o1) (patchOp o2) (patchOp o3)
-- STCOND o1 o2 o3 -> STCOND (patchOp o1) (patchOp o2) (patchOp o3)
-- 7. Atomic Memory Access Instructions --------------------------------------
+ AMSWAPDB f o1 o2 o3 -> AMSWAPDB f (patchOp o1) (patchOp o2) (patchOp o3)
-- 8. Barrier Instructions ---------------------------------------------------
- -- TODO: need fix
DBAR o1 -> DBAR o1
IBAR o1 -> IBAR o1
-- 11. Floating Point Instructions -------------------------------------------
@@ -734,6 +735,7 @@ data Instr
| PRELD Operand Operand
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- 7. Atomic Memory Access Instructions --------------------------------------
+ | AMSWAPDB Format Operand Operand Operand
-- 8. Barrier Instructions ---------------------------------------------------
| DBAR BarrierType
| IBAR BarrierType
@@ -755,8 +757,13 @@ data Instr
-- fnmadd: d = - r1 * r2 - r3
| FMA FMASign Operand Operand Operand Operand
--- TODO: Not complete.
-data BarrierType = Hint0
+data BarrierType
+ = Hint0
+ | Hint700
+ | HintAcquire
+ | HintRelease
+ | HintSeqcst
+ deriving (Eq, Show)
instrCon :: Instr -> String
instrCon i =
@@ -847,6 +854,7 @@ instrCon i =
LDPTR{} -> "LDPTR"
STPTR{} -> "STPTR"
PRELD{} -> "PRELD"
+ AMSWAPDB{} -> "AMSWAPDB"
DBAR{} -> "DBAR"
IBAR{} -> "IBAR"
FCVT{} -> "FCVT"
=====================================
compiler/GHC/CmmToAsm/LA64/Ppr.hs
=====================================
@@ -1015,6 +1015,10 @@ pprInstr platform instr = case instr of
-- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}
-- 7. Atomic Memory Access Instructions --------------------------------------
-- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU}
+ AMSWAPDB II8 o1 o2 o3 -> op3 (text "\tamswap_db.b") o1 o2 o3
+ AMSWAPDB II16 o1 o2 o3 -> op3 (text "\tamswap_db.h") o1 o2 o3
+ AMSWAPDB II32 o1 o2 o3 -> op3 (text "\tamswap_db.w") o1 o2 o3
+ AMSWAPDB II64 o1 o2 o3 -> op3 (text "\tamswap_db.d") o1 o2 o3
-- AM.{SWAP/ADD}[_DB].{B/H}
-- AMCAS[_DB].{B/H/W/D}
-- LL.{W/D}, SC.{W/D}
@@ -1112,19 +1116,28 @@ pprInstr platform instr = case instr of
op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
{-
- -- TODO: Support dbar with different hints.
+ Support dbar with different hints.
On LoongArch uses "dbar 0" (full completion barrier) for everything.
But the full completion barrier has no performance to tell, so
Loongson-3A6000 and newer processors have made finer granularity hints
available:
+ Hint 0x700: barrier for "read after read" from the same address.
Bit4: ordering or completion (0: completion, 1: ordering)
Bit3: barrier for previous read (0: true, 1: false)
Bit2: barrier for previous write (0: true, 1: false)
Bit1: barrier for succeeding read (0: true, 1: false)
Bit0: barrier for succeeding write (0: true, 1: false)
+
+ DBAR 0b10100: acquire
+ DBAR 0b10010: release
+ DBAR 0b10000: seqcst
-}
pprBarrierType Hint0 = text "0x0"
+ pprBarrierType HintSeqcst = text "0x10"
+ pprBarrierType HintRelease = text "0x12"
+ pprBarrierType HintAcquire = text "0x14"
+ pprBarrierType Hint700 = text "0x700"
floatPrecission o | isSingleOp o = text "s"
| isDoubleOp o = text "d"
| otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)
=====================================
compiler/GHC/Core/LateCC/OverloadedCalls.hs
=====================================
@@ -20,7 +20,6 @@ import GHC.Core.Make
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Utils
-import GHC.Tc.Utils.TcType
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.SrcLoc
@@ -29,6 +28,41 @@ import GHC.Types.Var
type OverloadedCallsCCState = Strict.Maybe SrcSpan
+{- Note [Overloaded Calls and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently GHC considers cost centres as destructive to
+join contexts. Or in other words this is not considered valid:
+
+ join f x = ...
+ in
+ ... -> scc<tick> jmp
+
+This makes the functionality of `-fprof-late-overloaded-calls` not feasible
+for join points in general. We used to try to work around this by putting the
+ticks on the rhs of the join point rather than around the jump. However beyond
+the loss of accuracy this was broken for recursive join points as we ended up
+with something like:
+
+ rec-join f x = scc<tick> ... jmp f x
+
+Which similarly is not valid as the tick once again destroys the tail call.
+One might think we could limit ourselves to non-recursive tail calls and do
+something clever like:
+
+ join f x = scc<tick> ...
+ in ... jmp f x
+
+And sometimes this works! But sometimes the full rhs would look something like:
+
+ join g x = ....
+ join f x = scc<tick> ... -> jmp g x
+
+Which, would again no longer be valid. I believe in the long run we can make
+cost centre ticks non-destructive to join points. Or we could keep track of
+where we are/are not allowed to insert a cost centre. But in the short term I will
+simply disable the annotation of join calls under this flag.
+-}
+
-- | Insert cost centres on function applications with dictionary arguments. The
-- source locations attached to the cost centres is approximated based on the
-- "closest" source note encountered in the traversal.
@@ -52,21 +86,10 @@ overloadedCallsCC =
CoreBndr
-> LateCCM OverloadedCallsCCState CoreExpr
-> LateCCM OverloadedCallsCCState CoreExpr
- wrap_if_join b pexpr = do
+ wrap_if_join _b pexpr = do
+ -- See Note [Overloaded Calls and join points]
expr <- pexpr
- if isJoinId b && isOverloadedTy (exprType expr) then do
- let
- cc_name :: FastString
- cc_name = fsLit "join-rhs-" `appendFS` getOccFS b
-
- cc_srcspan <-
- fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
- lift $ gets lateCCState_extra
-
- insertCC cc_name cc_srcspan expr
- else
- return expr
-
+ return expr
processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr
processExpr expr =
@@ -99,6 +122,7 @@ overloadedCallsCC =
-- Avoid instrumenting join points.
-- (See comment in processBind above)
+ -- Also see Note [Overloaded Calls and join points]
&& not (isJoinVarExpr f)
then do
-- Extract a name and source location from the function being
=====================================
docs/users_guide/profiling.rst
=====================================
@@ -571,9 +571,7 @@ of your profiled program will be different to that of the unprofiled one.
Some overloaded calls may not be annotated, specifically in cases where the
optimizer turns an overloaded function into a join point. Calls to such
functions will not be wrapped in ``SCC`` annotations, since it would make
- them non-tail calls, which is a requirement for join points. Instead,
- ``SCC`` annotations are added around the body of overloaded join variables
- and given distinct names (``join-rhs-<var>``) to avoid confusion.
+ them non-tail calls, which is a requirement for join points.
.. ghc-flag:: -fprof-cafs
:shortdesc: Auto-add ``SCC``\\ s to all CAFs
=====================================
libraries/base/changelog.md
=====================================
@@ -1,5 +1,8 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
+## 4.23.0.0 *TBA*
+ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337))
+
## 4.22.0.0 *TBA*
* Define `displayException` of `SomeAsyncException` to unwrap the exception.
([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309))
=====================================
libraries/base/src/Data/List/NonEmpty.hs
=====================================
@@ -78,6 +78,7 @@ module Data.List.NonEmpty (
, span -- :: (a -> Bool) -> NonEmpty a -> ([a], [a])
, break -- :: (a -> Bool) -> NonEmpty a -> ([a], [a])
, filter -- :: (a -> Bool) -> NonEmpty a -> [a]
+ , mapMaybe -- :: (a -> Maybe b) -> NonEmpty a -> [b]
, partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a])
, group -- :: (Foldable f, Eq a) => f a -> [NonEmpty a]
, groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a]
@@ -118,6 +119,7 @@ import qualified Prelude
import Control.Applicative (Applicative (..), Alternative (many))
import qualified Data.List as List
+import qualified Data.Maybe as List (mapMaybe)
import GHC.Internal.Data.Foldable hiding (length, toList)
import qualified GHC.Internal.Data.Foldable as Foldable
import GHC.Internal.Data.Function (on)
@@ -442,6 +444,14 @@ break p = span (not . p)
filter :: (a -> Bool) -> NonEmpty a -> [a]
filter p = List.filter p . toList
+-- | The 'mapMaybe' function is a version of 'map' which can throw
+-- out elements. In particular, the functional argument returns
+-- something of type @'Maybe' b@. If this is 'Nothing', no element
+-- is added on to the result list. If it is @'Just' b@, then @b@ is
+-- included in the result list.
+mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b]
+mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs
+
-- | The 'partition' function takes a predicate @p@ and a stream
-- @xs@, and returns a pair of lists. The first list corresponds to the
-- elements of @xs@ for which @p@ holds; the second corresponds to the
=====================================
mk/get-win32-tarballs.py
=====================================
@@ -8,7 +8,7 @@ import argparse
import sys
from sys import stderr
-TARBALL_VERSION = '0.8'
+TARBALL_VERSION = '0.9'
BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION)
DEST = Path('ghc-tarballs/mingw-w64')
ARCHS = ['x86_64', 'sources']
=====================================
rts/ProfHeap.c
=====================================
@@ -557,7 +557,7 @@ initHeapProfiling(void)
restore_locale();
- traceHeapProfBegin(0);
+ traceInitEvent(traceHeapProfBegin);
}
void
@@ -896,17 +896,17 @@ dumpCensus( Census *census )
// Eventlog
- traceHeapProfSampleString(0, "VOID",
+ traceHeapProfSampleString("VOID",
(census->void_total * sizeof(W_)));
- traceHeapProfSampleString(0, "LAG",
+ traceHeapProfSampleString("LAG",
((census->not_used - census->void_total) *
sizeof(W_)));
- traceHeapProfSampleString(0, "USE",
+ traceHeapProfSampleString("USE",
((census->used - census->drag_total) *
sizeof(W_)));
- traceHeapProfSampleString(0, "INHERENT_USE",
+ traceHeapProfSampleString("INHERENT_USE",
(census->prim * sizeof(W_)));
- traceHeapProfSampleString(0, "DRAG",
+ traceHeapProfSampleString("DRAG",
(census->drag_total * sizeof(W_)));
traceHeapProfSampleEnd(era);
@@ -941,33 +941,33 @@ dumpCensus( Census *census )
switch (RtsFlags.ProfFlags.doHeapProfile) {
case HEAP_BY_CLOSURE_TYPE:
fprintf(hp_file, "%s", (char *)ctr->identity);
- traceHeapProfSampleString(0, (char *)ctr->identity,
+ traceHeapProfSampleString((char *)ctr->identity,
count * sizeof(W_));
break;
case HEAP_BY_INFO_TABLE:
fprintf(hp_file, "%p", ctr->identity);
char str[100];
sprintf(str, "%p", ctr->identity);
- traceHeapProfSampleString(0, str, count * sizeof(W_));
+ traceHeapProfSampleString(str, count * sizeof(W_));
break;
#if defined(PROFILING)
case HEAP_BY_CCS:
fprint_ccs(hp_file, (CostCentreStack *)ctr->identity,
RtsFlags.ProfFlags.ccsLength);
- traceHeapProfSampleCostCentre(0, (CostCentreStack *)ctr->identity,
+ traceHeapProfSampleCostCentre((CostCentreStack *)ctr->identity,
count * sizeof(W_));
break;
case HEAP_BY_ERA:
fprintf(hp_file, "%" FMT_Word, (StgWord)ctr->identity);
char str_era[100];
sprintf(str_era, "%" FMT_Word, (StgWord)ctr->identity);
- traceHeapProfSampleString(0, str_era, count * sizeof(W_));
+ traceHeapProfSampleString(str_era, count * sizeof(W_));
break;
case HEAP_BY_MOD:
case HEAP_BY_DESCR:
case HEAP_BY_TYPE:
fprintf(hp_file, "%s", (char *)ctr->identity);
- traceHeapProfSampleString(0, (char *)ctr->identity,
+ traceHeapProfSampleString((char *)ctr->identity,
count * sizeof(W_));
break;
case HEAP_BY_RETAINER:
=====================================
rts/RetainerSet.c
=====================================
@@ -238,7 +238,7 @@ printRetainerSetShort(FILE *f, RetainerSet *rs, W_ total_size, uint32_t max_leng
}
}
fputs(tmp, f);
- traceHeapProfSampleString(0, tmp, total_size);
+ traceHeapProfSampleString(tmp, total_size);
}
/* -----------------------------------------------------------------------------
=====================================
rts/Trace.c
=====================================
@@ -647,10 +647,10 @@ void traceTaskDelete_ (Task *task)
}
}
-void traceHeapProfBegin(StgWord8 profile_id)
+void traceHeapProfBegin(void)
{
if (eventlog_enabled) {
- postHeapProfBegin(profile_id);
+ postHeapProfBegin();
}
}
void traceHeapBioProfSampleBegin(StgInt era, StgWord64 time)
@@ -674,11 +674,10 @@ void traceHeapProfSampleEnd(StgInt era)
}
}
-void traceHeapProfSampleString(StgWord8 profile_id,
- const char *label, StgWord residency)
+void traceHeapProfSampleString(const char *label, StgWord residency)
{
if (eventlog_enabled) {
- postHeapProfSampleString(profile_id, label, residency);
+ postHeapProfSampleString(label, residency);
}
}
@@ -718,11 +717,10 @@ void traceHeapProfCostCentre(StgWord32 ccID,
}
// This one is for .hp samples
-void traceHeapProfSampleCostCentre(StgWord8 profile_id,
- CostCentreStack *stack, StgWord residency)
+void traceHeapProfSampleCostCentre(CostCentreStack *stack, StgWord residency)
{
if (eventlog_enabled) {
- postHeapProfSampleCostCentre(profile_id, stack, residency);
+ postHeapProfSampleCostCentre(stack, residency);
}
}
=====================================
rts/Trace.h
=====================================
@@ -303,20 +303,18 @@ void traceTaskMigrate_ (Task *task,
void traceTaskDelete_ (Task *task);
-void traceHeapProfBegin(StgWord8 profile_id);
+void traceHeapProfBegin(void);
void traceHeapProfSampleBegin(StgInt era);
void traceHeapBioProfSampleBegin(StgInt era, StgWord64 time);
void traceHeapProfSampleEnd(StgInt era);
-void traceHeapProfSampleString(StgWord8 profile_id,
- const char *label, StgWord residency);
+void traceHeapProfSampleString(const char *label, StgWord residency);
#if defined(PROFILING)
void traceHeapProfCostCentre(StgWord32 ccID,
const char *label,
const char *module,
const char *srcloc,
StgBool is_caf);
-void traceHeapProfSampleCostCentre(StgWord8 profile_id,
- CostCentreStack *stack, StgWord residency);
+void traceHeapProfSampleCostCentre(CostCentreStack *stack, StgWord residency);
void traceProfSampleCostCentre(Capability *cap,
CostCentreStack *stack, StgWord ticks);
@@ -369,14 +367,14 @@ void flushTrace(void);
#define traceTaskCreate_(taskID, cap) /* nothing */
#define traceTaskMigrate_(taskID, cap, new_cap) /* nothing */
#define traceTaskDelete_(taskID) /* nothing */
-#define traceHeapProfBegin(profile_id) /* nothing */
+#define traceHeapProfBegin() /* nothing */
#define traceHeapProfCostCentre(ccID, label, module, srcloc, is_caf) /* nothing */
#define traceIPE(ipe) /* nothing */
#define traceHeapProfSampleBegin(era) /* nothing */
#define traceHeapBioProfSampleBegin(era, time) /* nothing */
#define traceHeapProfSampleEnd(era) /* nothing */
-#define traceHeapProfSampleCostCentre(profile_id, stack, residency) /* nothing */
-#define traceHeapProfSampleString(profile_id, label, residency) /* nothing */
+#define traceHeapProfSampleCostCentre(stack, residency) /* nothing */
+#define traceHeapProfSampleString(label, residency) /* nothing */
#define traceConcMarkBegin() /* nothing */
#define traceConcMarkEnd(marked_obj_count) /* nothing */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -95,6 +95,13 @@ bool eventlog_enabled; // protected by state_change_mutex to ensure
* buffer size, EVENT_LOG_SIZE. We must ensure that no variable-length event
* exceeds this limit. For this reason we impose maximum length limits on
* fields which may have unbounded values.
+ *
+ * Note [Profile ID]
+ * ~~~~~~~~~~~~~~~~~
+ * The profile ID field of eventlog entries is reserved for future use,
+ * with an eye towards supporting multiple parallel heap profiles.
+ * In the current RTS, the profile ID is hardcoded to 0.
+ *
*/
static const EventLogWriter *event_log_writer = NULL;
@@ -1219,7 +1226,7 @@ static HeapProfBreakdown getHeapProfBreakdown(void)
}
}
-void postHeapProfBegin(StgWord8 profile_id)
+void postHeapProfBegin(void)
{
ACQUIRE_LOCK(&eventBufMutex);
PROFILING_FLAGS *flags = &RtsFlags.ProfFlags;
@@ -1244,7 +1251,8 @@ void postHeapProfBegin(StgWord8 profile_id)
CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
postEventHeader(&eventBuf, EVENT_HEAP_PROF_BEGIN);
postPayloadSize(&eventBuf, len);
- postWord8(&eventBuf, profile_id);
+ // See Note [Profile ID].
+ postWord8(&eventBuf, 0);
postWord64(&eventBuf, TimeToNS(flags->heapProfileInterval));
postWord32(&eventBuf, getHeapProfBreakdown());
postStringLen(&eventBuf, flags->modSelector, modSelector_len);
@@ -1286,8 +1294,7 @@ void postHeapProfSampleEnd(StgInt era)
RELEASE_LOCK(&eventBufMutex);
}
-void postHeapProfSampleString(StgWord8 profile_id,
- const char *label,
+void postHeapProfSampleString(const char *label,
StgWord64 residency)
{
ACQUIRE_LOCK(&eventBufMutex);
@@ -1296,7 +1303,8 @@ void postHeapProfSampleString(StgWord8 profile_id,
CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_STRING);
postPayloadSize(&eventBuf, len);
- postWord8(&eventBuf, profile_id);
+ // See Note [Profile ID].
+ postWord8(&eventBuf, 0);
postWord64(&eventBuf, residency);
postStringLen(&eventBuf, label, label_len);
RELEASE_LOCK(&eventBufMutex);
@@ -1325,8 +1333,7 @@ void postHeapProfCostCentre(StgWord32 ccID,
RELEASE_LOCK(&eventBufMutex);
}
-void postHeapProfSampleCostCentre(StgWord8 profile_id,
- CostCentreStack *stack,
+void postHeapProfSampleCostCentre(CostCentreStack *stack,
StgWord64 residency)
{
ACQUIRE_LOCK(&eventBufMutex);
@@ -1340,7 +1347,8 @@ void postHeapProfSampleCostCentre(StgWord8 profile_id,
CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_COST_CENTRE);
postPayloadSize(&eventBuf, len);
- postWord8(&eventBuf, profile_id);
+ // See Note [Profile ID].
+ postWord8(&eventBuf, 0);
postWord64(&eventBuf, residency);
postWord8(&eventBuf, depth);
for (ccs = stack;
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -163,14 +163,13 @@ void postTaskMigrateEvent (EventTaskId taskId,
void postTaskDeleteEvent (EventTaskId taskId);
-void postHeapProfBegin(StgWord8 profile_id);
+void postHeapProfBegin(void);
void postHeapProfSampleBegin(StgInt era);
void postHeapBioProfSampleBegin(StgInt era, StgWord64 time_ns);
void postHeapProfSampleEnd(StgInt era);
-void postHeapProfSampleString(StgWord8 profile_id,
- const char *label,
+void postHeapProfSampleString(const char *label,
StgWord64 residency);
#if defined(PROFILING)
@@ -180,8 +179,7 @@ void postHeapProfCostCentre(StgWord32 ccID,
const char *srcloc,
StgBool is_caf);
-void postHeapProfSampleCostCentre(StgWord8 profile_id,
- CostCentreStack *stack,
+void postHeapProfSampleCostCentre(CostCentreStack *stack,
StgWord64 residency);
void postProfSampleCostCentre(Capability *cap,
=====================================
rts/linker/LoadArchive.c
=====================================
@@ -223,21 +223,22 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize,
size_t* fileNameSize)
{
- int n;
char *fileName = *fileName_;
if (isdigit(fileName[1])) {
- int i;
- for (n = 2; isdigit(fileName[n]); n++)
- ;
-
- fileName[n] = '\0';
- n = atoi(fileName + 1);
if (gnuFileIndex == NULL) {
errorBelch("loadArchive: GNU-variant filename "
"without an index while reading from `%" PATH_FMT "'",
path);
return false;
}
+
+ int n;
+ for (n = 2; isdigit(fileName[n]); n++)
+ ;
+
+ char *end;
+ fileName[n] = '\0';
+ n = strtol(fileName + 1, &end, 10);
if (n < 0 || n > gnuFileIndexSize) {
errorBelch("loadArchive: GNU-variant filename "
"offset %d out of range [0..%d] "
@@ -245,17 +246,27 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
n, gnuFileIndexSize, path);
return false;
}
- if (n != 0 && gnuFileIndex[n - 1] != '\n') {
+
+ // Check that the previous entry ends with the expected
+ // end-of-string delimiter.
+#if defined(mingw32_HOST_OS)
+#define IS_SYMBOL_DELIMITER(STR) (STR =='\n' || STR == '\0')
+#else
+#define IS_SYMBOL_DELIMITER(STR) (STR =='\n')
+#endif
+ if (n != 0 && !IS_SYMBOL_DELIMITER(gnuFileIndex[n - 1])) {
errorBelch("loadArchive: GNU-variant filename offset "
"%d invalid (range [0..%d]) while reading "
"filename from `%" PATH_FMT "'",
n, gnuFileIndexSize, path);
return false;
}
- for (i = n; gnuFileIndex[i] != '\n'; i++)
+
+ int i;
+ for (i = n; !IS_SYMBOL_DELIMITER(gnuFileIndex[i]); i++)
;
- size_t FileNameSize = i - n - 1;
+ size_t FileNameSize = i - n;
if (FileNameSize >= *fileNameSize) {
/* Double it to avoid potentially continually
increasing it by 1 */
@@ -264,6 +275,13 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
"loadArchive(fileName)");
}
memcpy(fileName, gnuFileIndex + n, FileNameSize);
+
+
+ /* llvm-ar terminates string table entries with `/\n`. */
+ if (fileName[FileNameSize-1] == '/') {
+ FileNameSize--;
+ }
+
fileName[FileNameSize] = '\0';
*thisFileNameSize = FileNameSize;
}
=====================================
rts/linker/PEi386.c
=====================================
@@ -342,6 +342,98 @@
Finally, we enter `ocResolve`, where we resolve relocations and and allocate
jump islands (using the m32 allocator for backing storage) as necessary.
+ Note [Windows API Set]
+ ~~~~~~~~~~~~~~~~~~~~~~
+ Windows has a concept called API Sets [1][2] which is intended to be Windows's
+ equivalent to glibc's symbolic versioning. It is also used to handle the API
+ surface difference between different device classes. e.g. the API might be
+ handled differently between a desktop and tablet.
+
+ This is handled through two mechanisms:
+
+ 1. Direct Forward: These use import libraries to manage to first level
+ redirection. So what used to be in ucrt.dll is now redirected based on
+ ucrt.lib. Every API now points to a possible different set of API sets
+ each following the API set contract:
+
+ * The name must begin either with the string api- or ext-.
+ * Names that begin with api- represent APIs that exist on all Windows
+ editions that satisfy the API's version requirements.
+ * Names that begin with ext- represent APIs that may not exist on all
+ Windows editions.
+ * The name must end with the sequence l<n>-<n>-<n>, where n consists of
+ decimal digits.
+ * The body of the name can be alphanumeric characters, or dashes (-).
+ * The name is case insensitive.
+
+ Here are some examples of API set contract names:
+
+ - api-ms-win-core-ums-l1-1-0
+ - ext-ms-win-com-ole32-l1-1-5
+ - ext-ms-win-ntuser-window-l1-1-0
+ - ext-ms-win-ntuser-window-l1-1-1
+
+ Forward references don't require anything special from the calling
+ application in that the Windows loader through "LoadLibrary" will
+ automatically load the right reference for you if given an API set
+ name including the ".dll" suffix. For example:
+
+ INFO: DLL api-ms-win-eventing-provider-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-apiquery-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\ntdll.dll by API set
+ INFO: DLL api-ms-win-core-processthreads-l1-1-3.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-processthreads-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-processthreads-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-processthreads-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-registry-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-heap-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-heap-l2-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-memory-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-memory-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-memory-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+ INFO: DLL api-ms-win-core-handle-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
+
+ Which shows how the loader has redirected some of the references used
+ by ghci.
+
+ Historically though we've treated shared libs lazily. We would load\
+ the shared library, but not resolve the symbol immediately and wait until
+ the symbol is requested to iterate in order through the shared libraries.
+
+ This assumes that you ever only had one version of a symbol. i.e. we had
+ an assumption that all exported symbols in different shared libraries
+ should be the same, because most of the time they come from re-exporting
+ from a base library. This is a bit of a weak assumption and doesn't hold
+ with API Sets.
+
+ For that reason the loader now resolves symbols immediately, and because
+ we now resolve using BIND_NOW we must make sure that a symbol loaded
+ through an OC has precedent because the BIND_NOW refernce was not asked
+ for. For that reason we load the symbols for API sets with the
+ SYM_TYPE_DUP_DISCARD flag set.
+
+ 2. Reverse forwarders: This is when the application has a direct reference
+ to the old name of an API. e.g. if GHC still used "msvcrt.dll" or
+ "ucrt.dll" we would have had to deal with this case. In this case the
+ loader intercepts the call and if it exists the dll is loaded. There is
+ an extra indirection as you go from foo.dll => api-ms-foo-1.dll => foo_imp.dll
+
+ But if the API doesn't exist on the device it's resolved to a stub in the
+ API set that if called will result in an error should it be called [3].
+
+ This means that usages of GetProcAddress and LoadLibrary to check for the
+ existance of a function aren't safe, because they'll always succeed, but may
+ result in a pointer to the stub rather than the actual function.
+
+ WHat does this mean for the RTS linker? Nothing. We don't have a fallback
+ for if the function doesn't exist. The RTS is merely just executing what
+ it was told to run. It's writers of libraries that have to be careful when
+ doing dlopen()/LoadLibrary.
+
+
+ [1] https://learn.microsoft.com/en-us/windows/win32/apiindex/windows-apisets
+ [2] https://mingwpy.github.io/ucrt.html#api-set-implementation
+ [3] https://learn.microsoft.com/en-us/windows/win32/apiindex/detect-api-set-ava…
+
*/
#include "Rts.h"
@@ -882,7 +974,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded )
goto error;
}
} else {
- goto loaded; /* We're done. DLL has been loaded. */
+ goto loaded_ok; /* We're done. DLL has been loaded. */
}
}
}
@@ -890,7 +982,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded )
// We failed to load
goto error;
-loaded:
+loaded_ok:
addLoadedDll(&loaded_dll_cache, dll_name, instance);
addDLLHandle(buf, instance);
if (loaded) {
@@ -1055,7 +1147,8 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
// We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL`
// is now a wrapper around `loadNativeObj` which acquires a lock which we
// already have here.
- const char* result = addDLL_PEi386(dll, NULL);
+ HINSTANCE instance;
+ const char* result = addDLL_PEi386(dll, &instance);
stgFree(image);
@@ -1069,6 +1162,28 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
}
stgFree(dll);
+
+ // See Note [Windows API Set]
+ // We must immediately tie the symbol to the shared library. The easiest
+ // way is to load the symbol immediately. We already have all the
+ // information so might as well
+ SymbolAddr* sym = lookupSymbolInDLL_PEi386 (symbol, instance, dll, NULL);
+
+ // Could be an import descriptor etc, skip if no symbol.
+ if (!sym)
+ return true;
+
+ // The symbol must have been found, and we can add it to the RTS symbol table
+ IF_DEBUG(linker, debugBelch("checkAndLoadImportLibrary: resolved symbol %s to %p\n", symbol, sym));
+ // Because the symbol has been loaded before we actually need it, if a
+ // stronger reference wants to add a duplicate we should discard this
+ // one to preserve link order.
+ SymType symType = SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN;
+ symType |= hdr.Type == IMPORT_OBJECT_CODE ? SYM_TYPE_CODE : SYM_TYPE_DATA;
+
+ if (!ghciInsertSymbolTable(dll, symhash, symbol, sym, false, symType, NULL))
+ return false;
+
return true;
}
@@ -1198,7 +1313,7 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
it generates call *__imp_foo, and __imp_foo here has exactly
the same semantics as in __imp_foo = GetProcAddress(..., "foo")
*/
- if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) {
+ if (sym == NULL && dependent && strncmp (lbl, "__imp_", 6) == 0) {
sym = GetProcAddress(instance,
lbl + 6);
if (sym != NULL) {
@@ -1214,12 +1329,6 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
}
}
- sym = GetProcAddress(instance, lbl);
- if (sym != NULL) {
- /*debugBelch("found %s in %s\n", lbl,dll_name);*/
- return sym;
- }
-
return NULL;
}
@@ -1821,6 +1930,27 @@ ocGetNames_PEi386 ( ObjectCode* oc )
}
if(NULL != targetSection)
addr = (SymbolAddr*) ((size_t) targetSection->start + getSymValue(info, targetSym));
+ else
+ {
+ // Do the symbol lookup based on name, this follows Microsoft's weak external's
+ // format 3 specifications. Example header generated:
+ // api-ms-win-crt-stdio-l1-1-0.dll: file format pe-x86-64
+ //
+ // SYMBOL TABLE:
+ // [ 0](sec -1)(fl 0x00)(ty 0)(scl 3) (nx 0) 0x0000000000000000 @comp.id
+ // [ 1](sec -1)(fl 0x00)(ty 0)(scl 3) (nx 0) 0x0000000000000000 @feat.00
+ // [ 2](sec 0)(fl 0x00)(ty 0)(scl 2) (nx 0) 0x0000000000000000 _write
+ // [ 3](sec 0)(fl 0x00)(ty 0)(scl 105) (nx 1) 0x0000000000000000 write
+ // AUX lnno 3 size 0x0 tagndx 2
+ //
+ // https://learn.microsoft.com/en-us/windows/win32/debug/pe-format#auxiliary-f…
+ SymbolName *target_sname = get_sym_name (getSymShortName (info, targetSym), oc);
+ if (target_sname)
+ addr = lookupSymbol_PEi386 (target_sname, oc, &type);
+
+ IF_DEBUG(linker, debugBelch("weak external symbol @ %s => %s resolved to %p\n", \
+ sname, target_sname, addr));
+ }
}
else if ( secNumber == IMAGE_SYM_UNDEFINED && symValue > 0) {
/* This symbol isn't in any section at all, ie, global bss.
@@ -2115,6 +2245,13 @@ ocResolve_PEi386 ( ObjectCode* oc )
*(uint64_t *)pP = S + A;
break;
}
+ case 11: /* IMAGE_REL_AMD64_SECREL (PE constant 11) */
+ {
+ uint64_t offset = S - (uint64_t) section.start;
+ CHECK((uint32_t) offset == offset);
+ *(uint32_t *)pP = offset + A;
+ break;
+ }
case 2: /* R_X86_64_32 (ELF constant 10) - IMAGE_REL_AMD64_ADDR32 (PE constant 2) */
case 3: /* IMAGE_REL_AMD64_ADDR32NB (PE constant 3) */
case 17: /* R_X86_64_32S ELF constant, no PE mapping. See note [ELF constant in PE file] */
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where
last :: forall a. NonEmpty a -> a
length :: forall a. NonEmpty a -> GHC.Internal.Types.Int
map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
+ mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b]
nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where
last :: forall a. NonEmpty a -> a
length :: forall a. NonEmpty a -> GHC.Internal.Types.Int
map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
+ mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b]
nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where
last :: forall a. NonEmpty a -> a
length :: forall a. NonEmpty a -> GHC.Internal.Types.Int
map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
+ mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b]
nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where
last :: forall a. NonEmpty a -> a
length :: forall a. NonEmpty a -> GHC.Internal.Types.Int
map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
+ mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b]
nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a)
nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a
nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -426,9 +426,7 @@ test('T10296b', [only_ways(['threaded2'])], compile_and_run, [''])
test('numa001', [ extra_run_opts('8'), unless(unregisterised(), extra_ways(['debug_numa'])), req_ghc_with_threaded_rts ]
, compile_and_run, [''])
-test('T12497', [ unless(opsys('mingw32'), skip), expect_broken(22694)
- ],
- makefile_test, ['T12497'])
+test('T12497', unless(opsys('mingw32'), skip), makefile_test, ['T12497'])
test('T13617', [ unless(opsys('mingw32'), skip)],
makefile_test, ['T13617'])
=====================================
testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32
=====================================
@@ -3,7 +3,7 @@ GHC runtime linker: fatal error: I found a duplicate definition for symbol
whilst processing object file
E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libfoo_link_lib_3.a
The symbol was previously defined in
- E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#2:bar_link_lib_3.o)
+ E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#3:bar_link_lib_3.o)
This could be caused by:
* Loading two different object files which export the same symbol
* Specifying the same object file twice on the GHCi command line
=====================================
testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32
=====================================
@@ -3,7 +3,7 @@ GHC runtime linker: fatal error: I found a duplicate definition for symbol
whilst processing object file
E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libfoo_link_lib_3.a
The symbol was previously defined in
- E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#2:bar_link_lib_3.o)
+ E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#3:bar_link_lib_3.o)
This could be caused by:
* Loading two different object files which export the same symbol
* Specifying the same object file twice on the GHCi command line
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca9801eb27c2712f29b031505d6878…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca9801eb27c2712f29b031505d6878…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
16 Jul '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
848e1dcb by Simon Peyton Jones at 2025-07-16T22:55:31+01:00
Comments only [skip ci]
- - - - -
2 changed files:
- compiler/GHC/Tc/Solver/FunDeps.hs
- testsuite/tests/typecheck/should_compile/tc126.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -256,12 +256,12 @@ Consider T4254b:
From the ambiguity check on the type signature we get
[G] FD Int b
[W] FD Int beta
- If we ineract that Wanted with /both/ the t0p-level instance, /and/ the
+ If we interact that Wanted with /both/ the top-level instance, /and/ the
local Given, we'll get
beta ~ Int and beta ~ b
respectively. That would generate (b~Bool), which would fai. I think
it doesn't matter which of the two we pick, but historically we have
- picked teh local-fundeps firs.
+ picked the local-fundeps first.
(DFL2) Try solving from top-level instances before fundeps.
From the definition `foo = op` we get
=====================================
testsuite/tests/typecheck/should_compile/tc126.hs
=====================================
@@ -35,3 +35,50 @@ g2 = f (f (f [0::Int]))
-- The outer f repeats the exercise, so g2::Int
-- This is the definition that Hugs rejects
+
+{-
+start iteration=0
+ [W] $dBug_aET {0} :: Bug (Int -> Int) a_aER[tau:1] r_aES[tau:1] (CDictCan)
+ [W] $dBug_aEW {0} :: Bug (Int -> Int) [r_aFd[tau:1]] a_aER[tau:1] (CDictCan)
+ [W] $dBug_aF0 {0} :: Bug (Int -> Int) [Int] [r_aFd[tau:1]] (CDictCan)}
+-->
+ [W] $dBug_aET {0} :: Bug (Int -> Int) a_aER[tau:1] r_aES[tau:1] (CDictCan)
+ [W] $dBug_aEW {0} :: Bug (Int -> Int) [r_aFd[tau:1]] a_aER[tau:1] (CDictCan)
+ [W] $dBug_aF0 {0} :: Bug (Int -> Int) Int r_aFd[tau:1] (CDictCan)}
+--> fds
+ a_aER := [r_aFf]
+ r_fD := Int
+
+start iteration=1
+ [W] $dBug_aET {0} :: Bug (Int -> Int) [r_aFf[tau:1]] r_aES[tau:1] (CDictCan)
+ [W] $dBug_aEW {0} :: Bug (Int -> Int) [r_aFd[tau:1]] [r_aFf][tau:1]] (CDictCan)
+ [W] $dBug_aF0 {0} :: Bug (Int -> Int) Int Int (CDictCan)}
+--> (solve aF0, instance for aEW)
+ [W] $dBug_aET {0} :: Bug (Int -> Int) [r_aFf[tau:1]] r_aES[tau:1] (CDictCan)
+ [W] $dBug_aFg {1} :: Bug (Int -> Int) Int r_aFf[tau:1] (CDictCan)}
+--> fds
+ r_aES := [r_aFh] -- fresh r_aFh
+ r_aFf := Int
+
+start iteration=2
+ [W] $dBug_aET {0} :: Bug (Int -> Int) [Int] [r_afH[tau:1]] (CDictCan)
+ [W] $dBug_aFg {1} :: Bug (Int -> Int) Int Int (CDictCan)}
+--> (solve afG instance for aET
+ [W] $dBug_aFi {1} :: Bug (Int -> Int) Int r_aFh[tau:1] (CDictCan)}
+--> fds
+ f_afH := Int
+
+start iteration 3
+ [W] $dBug_aFi {1} :: Bug (Int -> Int) Int Int (CDictCan)}
+--> solve
+
+
+
+ [W] $dBug_aCv {0} :: Bug (Int -> Int) [r_aCL[tau:1]] r_aCu[tau:1] (CDictCan)
+ [W] $dBug_aEI {1} :: Bug (Int -> Int) Int r_aCL[tau:1] (CDictCan)}
+-->
+ r_aCL := Int
+ r_aCu := [ r_new ] -- r_aEJ
+
+ [W] Bug (Int -> Int) Int r_new
+-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/848e1dcbd1e191f70c411c0697cc5a6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/848e1dcbd1e191f70c411c0697cc5a6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
c8241b8a by Simon Peyton Jones at 2025-07-16T22:38:37+01:00
Wibble imports
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Specialise.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -70,8 +70,6 @@ import GHC.Core.Subst (substTickish)
import GHC.Core.TyCon (tyConClass_maybe)
import GHC.Core.DataCon (dataConTyCon)
-import Control.Monad
-
{-
************************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8241b8a27c5682347d3923453996aa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8241b8a27c5682347d3923453996aa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: NCG/LA64: Support finer-grained DBAR hints
by Marge Bot (＠marge-bot) 16 Jul '25
by Marge Bot (＠marge-bot) 16 Jul '25
16 Jul '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00
NCG/LA64: Support finer-grained DBAR hints
For LA664 and newer uarchs, they have made finer granularity hints
available:
Bit4: ordering or completion (0: completion, 1: ordering)
Bit3: barrier for previous read (0: true, 1: false)
Bit2: barrier for previous write (0: true, 1: false)
Bit1: barrier for succeeding read (0: true, 1: false)
Bit0: barrier for succeeding write (0: true, 1: false)
And not affect the existing models because other hints are treated
as 'dbar 0' there.
- - - - -
7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00
Disable -fprof-late-overloaded-calls for join points.
Currently GHC considers cost centres as destructive to
join contexts. Or in other words this is not considered valid:
join f x = ...
in
... -> scc<tick> jmp
This makes the functionality of `-fprof-late-overloaded-calls` not feasible
for join points in general. We used to try to work around this by putting the
ticks on the rhs of the join point rather than around the jump. However beyond
the loss of accuracy this was broken for recursive join points as we ended up
with something like:
rec-join f x = scc<tick> ... jmp f x
Which similarly is not valid as the tick once again destroys the tail call.
One might think we could limit ourselves to non-recursive tail calls and do
something clever like:
join f x = scc<tick> ...
in ... jmp f x
And sometimes this works! But sometimes the full rhs would look something like:
join g x = ....
join f x = scc<tick> ... -> jmp g x
Which, would again no longer be valid. I believe in the long run we can make
cost centre ticks non-destructive to join points. Or we could keep track of
where we are/are not allowed to insert a cost centre. But in the short term I will
simply disable the annotation of join calls under this flag.
- - - - -
93f01d7c by ARATA Mizuki at 2025-07-16T17:24:27-04:00
x86 NCG: Better lowering for shuffleFloatX4# and shuffleDoubleX2#
The new implementation
* make use of specialized instructions like (V)UNPCK{L,H}{PS,PD}, and
* do not require -mavx.
Close #26096
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
97654402 by Jappie Klooster at 2025-07-16T17:24:39-04:00
Update interact docs to explain about buffering
We need to tell the user to set to the
appropriate buffer format.
Otherwise, this function may get randomly stuck,
or just behave confusingly.
issue: https://gitlab.haskell.org/ghc/ghc/-/issues/26131
NB, I'm running this with cabal *NOT* ghci. ghci messes with buffering anyway.
```haskell
interaction :: String -> String
interaction "jappie" = "hi"
interaction "jakob" = "hello"
interaction x = "unkown input: " <> x
main :: IO ()
main = interact interaction
```
so in my input (prefixed by `>`) I get:
```
> jappie
unkown input: jappie
```
we confirmed later this was due to lack of \n matching.
Anyway movnig on to more unexpected stuff:
```haskell
main :: IO ()
main = do
interact (concatMap interaction . lines)
```
get's stuck forever.
actually `^D` (ctrl+d) unstucks it and runs all input as expected.
for example you can get:
```
> sdfkds
> fakdsf
unkown input: sdfkdsunkown input: fakdsf
```
This program works!
```haskell
interaction :: String -> String
interaction "jappie" = "hi \n"
interaction "jakob" = "hello \n"
interaction x = "unkown input: " <> x <> "\n"
main :: IO ()
main = do
interact (concatMap interaction . lines)
```
the reason is that linebuffering is set for both in and output by default.
so lines eats the input lines, and all the \n postfixes make sure the buffer
is put out.
- - - - -
782033f3 by Zubin Duggal at 2025-07-16T17:24:40-04:00
fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory
Fixes #24093
- - - - -
20 changed files:
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/profiling.rst
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/doublex2_shuffle.hs
- + testsuite/tests/simd/should_run/doublex2_shuffle.stdout
- + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.hs
- + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.stdout
- + testsuite/tests/simd/should_run/floatx4_shuffle.hs
- + testsuite/tests/simd/should_run/floatx4_shuffle.stdout
- + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.hs
- + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/847209fa954a24f8abaf39de9f7de8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/847209fa954a24f8abaf39de9f7de8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Disable -fprof-late-overloaded-calls for join points.
by Marge Bot (＠marge-bot) 16 Jul '25
by Marge Bot (＠marge-bot) 16 Jul '25
16 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00
Disable -fprof-late-overloaded-calls for join points.
Currently GHC considers cost centres as destructive to
join contexts. Or in other words this is not considered valid:
join f x = ...
in
... -> scc<tick> jmp
This makes the functionality of `-fprof-late-overloaded-calls` not feasible
for join points in general. We used to try to work around this by putting the
ticks on the rhs of the join point rather than around the jump. However beyond
the loss of accuracy this was broken for recursive join points as we ended up
with something like:
rec-join f x = scc<tick> ... jmp f x
Which similarly is not valid as the tick once again destroys the tail call.
One might think we could limit ourselves to non-recursive tail calls and do
something clever like:
join f x = scc<tick> ...
in ... jmp f x
And sometimes this works! But sometimes the full rhs would look something like:
join g x = ....
join f x = scc<tick> ... -> jmp g x
Which, would again no longer be valid. I believe in the long run we can make
cost centre ticks non-destructive to join points. Or we could keep track of
where we are/are not allowed to insert a cost centre. But in the short term I will
simply disable the annotation of join calls under this flag.
- - - - -
2 changed files:
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- docs/users_guide/profiling.rst
Changes:
=====================================
compiler/GHC/Core/LateCC/OverloadedCalls.hs
=====================================
@@ -20,7 +20,6 @@ import GHC.Core.Make
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Utils
-import GHC.Tc.Utils.TcType
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.SrcLoc
@@ -29,6 +28,41 @@ import GHC.Types.Var
type OverloadedCallsCCState = Strict.Maybe SrcSpan
+{- Note [Overloaded Calls and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently GHC considers cost centres as destructive to
+join contexts. Or in other words this is not considered valid:
+
+ join f x = ...
+ in
+ ... -> scc<tick> jmp
+
+This makes the functionality of `-fprof-late-overloaded-calls` not feasible
+for join points in general. We used to try to work around this by putting the
+ticks on the rhs of the join point rather than around the jump. However beyond
+the loss of accuracy this was broken for recursive join points as we ended up
+with something like:
+
+ rec-join f x = scc<tick> ... jmp f x
+
+Which similarly is not valid as the tick once again destroys the tail call.
+One might think we could limit ourselves to non-recursive tail calls and do
+something clever like:
+
+ join f x = scc<tick> ...
+ in ... jmp f x
+
+And sometimes this works! But sometimes the full rhs would look something like:
+
+ join g x = ....
+ join f x = scc<tick> ... -> jmp g x
+
+Which, would again no longer be valid. I believe in the long run we can make
+cost centre ticks non-destructive to join points. Or we could keep track of
+where we are/are not allowed to insert a cost centre. But in the short term I will
+simply disable the annotation of join calls under this flag.
+-}
+
-- | Insert cost centres on function applications with dictionary arguments. The
-- source locations attached to the cost centres is approximated based on the
-- "closest" source note encountered in the traversal.
@@ -52,21 +86,10 @@ overloadedCallsCC =
CoreBndr
-> LateCCM OverloadedCallsCCState CoreExpr
-> LateCCM OverloadedCallsCCState CoreExpr
- wrap_if_join b pexpr = do
+ wrap_if_join _b pexpr = do
+ -- See Note [Overloaded Calls and join points]
expr <- pexpr
- if isJoinId b && isOverloadedTy (exprType expr) then do
- let
- cc_name :: FastString
- cc_name = fsLit "join-rhs-" `appendFS` getOccFS b
-
- cc_srcspan <-
- fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
- lift $ gets lateCCState_extra
-
- insertCC cc_name cc_srcspan expr
- else
- return expr
-
+ return expr
processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr
processExpr expr =
@@ -99,6 +122,7 @@ overloadedCallsCC =
-- Avoid instrumenting join points.
-- (See comment in processBind above)
+ -- Also see Note [Overloaded Calls and join points]
&& not (isJoinVarExpr f)
then do
-- Extract a name and source location from the function being
=====================================
docs/users_guide/profiling.rst
=====================================
@@ -571,9 +571,7 @@ of your profiled program will be different to that of the unprofiled one.
Some overloaded calls may not be annotated, specifically in cases where the
optimizer turns an overloaded function into a join point. Calls to such
functions will not be wrapped in ``SCC`` annotations, since it would make
- them non-tail calls, which is a requirement for join points. Instead,
- ``SCC`` annotations are added around the body of overloaded join variables
- and given distinct names (``join-rhs-<var>``) to avoid confusion.
+ them non-tail calls, which is a requirement for join points.
.. ghc-flag:: -fprof-cafs
:shortdesc: Auto-add ``SCC``\\ s to all CAFs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7da86e165612721c4e09f772a3fdaff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7da86e165612721c4e09f772a3fdaff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] NCG/LA64: Support finer-grained DBAR hints
by Marge Bot (＠marge-bot) 16 Jul '25
by Marge Bot (＠marge-bot) 16 Jul '25
16 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00
NCG/LA64: Support finer-grained DBAR hints
For LA664 and newer uarchs, they have made finer granularity hints
available:
Bit4: ordering or completion (0: completion, 1: ordering)
Bit3: barrier for previous read (0: true, 1: false)
Bit2: barrier for previous write (0: true, 1: false)
Bit1: barrier for succeeding read (0: true, 1: false)
Bit0: barrier for succeeding write (0: true, 1: false)
And not affect the existing models because other hints are treated
as 'dbar 0' there.
- - - - -
3 changed files:
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Instr.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/LA64/CodeGen.hs
=====================================
@@ -1910,13 +1910,12 @@ genCCall target dest_regs arg_regs = do
MO_W64X2_Max -> unsupported mop
-- Memory Ordering
- -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.
- -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;
- -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.
-
- MO_AcquireFence -> pure (unitOL (DBAR Hint0))
- MO_ReleaseFence -> pure (unitOL (DBAR Hint0))
- MO_SeqCstFence -> pure (unitOL (DBAR Hint0))
+ -- Support finer-grained DBAR hints for LA664 and newer uarchs.
+ -- These are treated as DBAR 0 on older uarchs, so we can start
+ -- to unconditionally emit the new hints right away.
+ MO_AcquireFence -> pure (unitOL (DBAR HintAcquire))
+ MO_ReleaseFence -> pure (unitOL (DBAR HintRelease))
+ MO_SeqCstFence -> pure (unitOL (DBAR HintSeqcst))
MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)
-- Prefetch
@@ -1954,12 +1953,11 @@ genCCall target dest_regs arg_regs = do
MemOrderAcquire -> toOL [
ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
- DBAR Hint0
+ DBAR HintAcquire
]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR Hint0),
- LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),
- DBAR Hint0
+ MemOrderSeqCst -> toOL [
+ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
+ DBAR HintSeqcst
]
_ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
dst = getRegisterReg platform (CmmLocal dst_reg)
@@ -1974,15 +1972,9 @@ genCCall target dest_regs arg_regs = do
(val, fmt_val, code_val) <- getSomeReg val_reg
let instrs = case ord of
MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))
- MemOrderRelease -> toOL [
- ann moDescr (DBAR Hint0),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- ]
- MemOrderSeqCst -> toOL [
- ann moDescr (DBAR Hint0),
- ST fmt_val (OpReg w val) (OpAddr $ AddrReg p),
- DBAR Hint0
- ]
+ -- implement with AMSWAPDB
+ MemOrderRelease -> unitOL $ ann moDescr (AMSWAPDB fmt_val (OpReg w zeroReg) (OpReg w val) (OpReg w p))
+ MemOrderSeqCst -> unitOL $ ann moDescr (AMSWAPDB fmt_val (OpReg w zeroReg) (OpReg w val) (OpReg w p))
_ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
moDescr = (text . show) mo
code =
=====================================
compiler/GHC/CmmToAsm/LA64/Instr.hs
=====================================
@@ -169,6 +169,7 @@ regUsageOfInstr platform instr = case instr of
-- LDCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- STCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- 7. Atomic Memory Access Instructions --------------------------------------
+ AMSWAPDB _ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
-- 8. Barrier Instructions ---------------------------------------------------
DBAR _hint -> usage ([], [])
IBAR _hint -> usage ([], [])
@@ -343,13 +344,13 @@ patchRegsOfInstr instr env = case instr of
STX f o1 o2 -> STX f (patchOp o1) (patchOp o2)
LDPTR f o1 o2 -> LDPTR f (patchOp o1) (patchOp o2)
STPTR f o1 o2 -> STPTR f (patchOp o1) (patchOp o2)
- PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2)
+ PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2)
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- LDCOND o1 o2 o3 -> LDCOND (patchOp o1) (patchOp o2) (patchOp o3)
-- STCOND o1 o2 o3 -> STCOND (patchOp o1) (patchOp o2) (patchOp o3)
-- 7. Atomic Memory Access Instructions --------------------------------------
+ AMSWAPDB f o1 o2 o3 -> AMSWAPDB f (patchOp o1) (patchOp o2) (patchOp o3)
-- 8. Barrier Instructions ---------------------------------------------------
- -- TODO: need fix
DBAR o1 -> DBAR o1
IBAR o1 -> IBAR o1
-- 11. Floating Point Instructions -------------------------------------------
@@ -734,6 +735,7 @@ data Instr
| PRELD Operand Operand
-- 6. Bound Check Memory Access Instructions ---------------------------------
-- 7. Atomic Memory Access Instructions --------------------------------------
+ | AMSWAPDB Format Operand Operand Operand
-- 8. Barrier Instructions ---------------------------------------------------
| DBAR BarrierType
| IBAR BarrierType
@@ -755,8 +757,13 @@ data Instr
-- fnmadd: d = - r1 * r2 - r3
| FMA FMASign Operand Operand Operand Operand
--- TODO: Not complete.
-data BarrierType = Hint0
+data BarrierType
+ = Hint0
+ | Hint700
+ | HintAcquire
+ | HintRelease
+ | HintSeqcst
+ deriving (Eq, Show)
instrCon :: Instr -> String
instrCon i =
@@ -847,6 +854,7 @@ instrCon i =
LDPTR{} -> "LDPTR"
STPTR{} -> "STPTR"
PRELD{} -> "PRELD"
+ AMSWAPDB{} -> "AMSWAPDB"
DBAR{} -> "DBAR"
IBAR{} -> "IBAR"
FCVT{} -> "FCVT"
=====================================
compiler/GHC/CmmToAsm/LA64/Ppr.hs
=====================================
@@ -1015,6 +1015,10 @@ pprInstr platform instr = case instr of
-- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}
-- 7. Atomic Memory Access Instructions --------------------------------------
-- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU}
+ AMSWAPDB II8 o1 o2 o3 -> op3 (text "\tamswap_db.b") o1 o2 o3
+ AMSWAPDB II16 o1 o2 o3 -> op3 (text "\tamswap_db.h") o1 o2 o3
+ AMSWAPDB II32 o1 o2 o3 -> op3 (text "\tamswap_db.w") o1 o2 o3
+ AMSWAPDB II64 o1 o2 o3 -> op3 (text "\tamswap_db.d") o1 o2 o3
-- AM.{SWAP/ADD}[_DB].{B/H}
-- AMCAS[_DB].{B/H/W/D}
-- LL.{W/D}, SC.{W/D}
@@ -1112,19 +1116,28 @@ pprInstr platform instr = case instr of
op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
{-
- -- TODO: Support dbar with different hints.
+ Support dbar with different hints.
On LoongArch uses "dbar 0" (full completion barrier) for everything.
But the full completion barrier has no performance to tell, so
Loongson-3A6000 and newer processors have made finer granularity hints
available:
+ Hint 0x700: barrier for "read after read" from the same address.
Bit4: ordering or completion (0: completion, 1: ordering)
Bit3: barrier for previous read (0: true, 1: false)
Bit2: barrier for previous write (0: true, 1: false)
Bit1: barrier for succeeding read (0: true, 1: false)
Bit0: barrier for succeeding write (0: true, 1: false)
+
+ DBAR 0b10100: acquire
+ DBAR 0b10010: release
+ DBAR 0b10000: seqcst
-}
pprBarrierType Hint0 = text "0x0"
+ pprBarrierType HintSeqcst = text "0x10"
+ pprBarrierType HintRelease = text "0x12"
+ pprBarrierType HintAcquire = text "0x14"
+ pprBarrierType Hint700 = text "0x700"
floatPrecission o | isSingleOp o = text "s"
| isDoubleOp o = text "d"
| otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbaa44a784fb041ee91858743eaa7e0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbaa44a784fb041ee91858743eaa7e0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/24212] Read Toolchain.Target files rather than 'settings'
by Rodrigo Mesquita (＠alt-romes) 16 Jul '25
by Rodrigo Mesquita (＠alt-romes) 16 Jul '25
16 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC
Commits:
5e74adc1 by Rodrigo Mesquita at 2025-07-16T19:11:39+01: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
=====================================
@@ -145,6 +145,7 @@ import GHC.Foreign (withCString, peekCString)
import qualified Data.Set as Set
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Toolchain.Target (Target)
-- -----------------------------------------------------------------------------
-- DynFlags
@@ -178,6 +179,7 @@ data DynFlags = DynFlags {
toolSettings :: {-# UNPACK #-} !ToolSettings,
platformMisc :: {-# UNPACK #-} !PlatformMisc,
rawSettings :: [(String, String)],
+ rawTarget :: Target,
tmpDir :: TempDir,
llvmOptLevel :: Int, -- ^ LLVM optimisation level
@@ -656,6 +658,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
@@ -403,6 +406,7 @@ settings dflags = Settings
, sToolSettings = toolSettings dflags
, sPlatformMisc = platformMisc dflags
, sRawSettings = rawSettings dflags
+ , sRawTarget = rawTarget dflags
}
pgm_L :: DynFlags -> String
@@ -3454,9 +3458,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),
@@ -3513,9 +3566,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]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -3843,3 +3903,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
@@ -752,8 +753,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/5e74adc114542a95a1b6cf1653b0139…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e74adc114542a95a1b6cf1653b0139…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26053] 2 commits: nonmoving: Use get_itbl instead of explicit loads
by Ben Gamari (＠bgamari) 16 Jul '25
by Ben Gamari (＠bgamari) 16 Jul '25
16 Jul '25
Ben Gamari pushed to branch wip/T26053 at Glasgow Haskell Compiler / GHC
Commits:
18790528 by Ben Gamari at 2025-07-16T13:33:20-04:00
nonmoving: Use get_itbl instead of explicit loads
This is cleaner and also fixes unnecessary (and unsound) use of
`volatile`.
- - - - -
5cc0060c by Ben Gamari at 2025-07-16T13:39:31-04:00
rts/Scav: Handle WHITEHOLEs in scavenge_one
`scavenge_one`, used to scavenge mutable list entries, may encounter
`WHITEHOLE`s when the non-moving GC is in use via two paths:
1. when an MVAR is being marked concurrently
2. when the object belongs to a chain of selectors being short-cutted.
Fixes #26204.
- - - - -
2 changed files:
- rts/sm/NonMovingMark.c
- rts/sm/Scav.c
Changes:
=====================================
rts/sm/NonMovingMark.c
=====================================
@@ -619,7 +619,7 @@ inline void updateRemembSetPushThunk(Capability *cap, StgThunk *thunk)
{
const StgInfoTable *info;
do {
- info = *(StgInfoTable* volatile*) &thunk->header.info;
+ info = get_itbl((StgClosure*) thunk);
} while (info == &stg_WHITEHOLE_info);
const StgThunkInfoTable *thunk_info = THUNK_INFO_PTR_TO_STRUCT(info);
@@ -1343,7 +1343,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin)
goto done;
case WHITEHOLE:
- while (*(StgInfoTable* volatile*) &p->header.info == &stg_WHITEHOLE_info)
+ while (get_itbl(p) == &stg_WHITEHOLE_info)
#if defined(PARALLEL_GC)
busy_wait_nop()
#endif
@@ -1714,7 +1714,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin)
break;
case WHITEHOLE:
- while (*(StgInfoTable* volatile*) &p->header.info == &stg_WHITEHOLE_info);
+ while (get_itbl(p) == &stg_WHITEHOLE_info);
goto try_again;
case COMPACT_NFDATA:
=====================================
rts/sm/Scav.c
=====================================
@@ -1276,6 +1276,7 @@ scavenge_one(StgPtr p)
bool no_luck;
bool saved_eager_promotion;
+try_again:
saved_eager_promotion = gct->eager_promotion;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
@@ -1617,6 +1618,13 @@ scavenge_one(StgPtr p)
scavenge_continuation((StgContinuation *)p);
break;
+ case WHITEHOLE:
+ // This may happen when the nonmoving GC is in use via two paths:
+ // 1. when an MVAR is being marked concurrently
+ // 2. when the object belongs to a chain of selectors being short-cutted.
+ while (get_itbl((StgClosure*) p) == &stg_WHITEHOLE_info);
+ goto try_again;
+
default:
barf("scavenge_one: strange object %d", (int)(info->type));
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba416f39b0c082eb35db526f761ca2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba416f39b0c082eb35db526f761ca2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/T17157 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T17157
You're receiving this email because of your account on gitlab.haskell.org.
1
0