[Git][ghc/ghc][master] JS: replace BigInt with Number arithmetic for 32/64-bit quot/rem (#23597)
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
89d9ba37 by Sylvain Henry at 2026-03-20T12:27:34-04:00
JS: replace BigInt with Number arithmetic for 32/64-bit quot/rem (#23597)
Replace BigInt-based implementations of quotWord32, remWord32,
quotRemWord32, quotRem2Word32, quotWord64, remWord64, quotInt64, and
remInt64 with pure Number (double/integer) arithmetic to avoid the
overhead of BigInt promotion.
- - - - -
1 changed file:
- rts/js/arith.js
Changes:
=====================================
rts/js/arith.js
=====================================
@@ -9,17 +9,8 @@ function h$logArith() { h$log.apply(h$log,arguments); }
#endif
#define UN(x) ((x)>>>0)
-#define W32(x) (BigInt(x))
-#define I32(x) (BigInt(x))
#define W64(h,l) ((BigInt(h) << BigInt(32)) | BigInt(l>>>0))
-#define W64h(x) (Number(x >> BigInt(32)) >>> 0)
-#define W64l(x) (Number(BigInt.asUintN(32, x)) >>> 0)
#define I64(h,l) ((BigInt(h) << BigInt(32)) | BigInt(l>>>0))
-#define I64h(x) (Number(x >> BigInt(32))|0)
-#define I64l(x) (Number(BigInt.asUintN(32,x)) >>> 0)
-#define RETURN_I64(x) RETURN_UBX_TUP2(I64h(x), I64l(x))
-#define RETURN_W64(x) RETURN_UBX_TUP2(W64h(x), W64l(x))
-#define RETURN_W32(x) return Number(x)
// N.B. 64-bit numbers are represented by two JS numbers,
@@ -27,20 +18,88 @@ function h$logArith() { h$log.apply(h$log,arguments); }
// See Note [StgToJS design] in GHC.StgToJS for details on
// number representation.
+// Internal helper: unsigned 64-bit division and remainder.
+// Inputs ah,al,bh,bl are all unsigned 32-bit.
+// Returns qh; sets h$ret1=ql, h$ret2=rh, h$ret3=rl.
+function h$quotRemWord64(ah, al, bh, bl) {
+ // Re-apply >>>0 to make Uint32 types explicit for JIT optimisation,
+ // rather than relying on callers to have done so.
+ ah >>>= 0; al >>>= 0; bh >>>= 0; bl >>>= 0;
+ if (bh === 0 && bl === 0) throw new Error("divide by zero");
+ var qh, ql, rh, rl;
+ if (bh === 0) {
+ // 32-bit divisor: long division in base 2^16
+ qh = Math.floor(ah / bl) >>> 0;
+ var r0 = ah - qh * bl;
+ var a1 = r0 * 65536 + (al >>> 16);
+ var q1 = Math.floor(a1 / bl);
+ var r1 = a1 - q1 * bl;
+ var a2 = r1 * 65536 + (al & 0xFFFF);
+ var q2 = Math.floor(a2 / bl);
+ ql = (q1 * 65536 + q2) >>> 0;
+ rl = (a2 - q2 * bl) >>> 0;
+ rh = 0;
+ } else {
+ // 64-bit divisor >= 2^32: quotient fits in 32 bits
+ qh = 0;
+ // Float approximation; error < 1 since q < 2^32 and relative fp error < 2^-52
+ var ql_f = Math.floor((ah * 4294967296 + al) / (bh * 4294967296 + bl));
+ if (ql_f > 4294967295) ql_f = 4294967295;
+ ql = ql_f >>> 0;
+ // Compute ql * b exactly once (two 32x32->64-bit products)
+ var m1h = h$mul2Word32(ql, bl); var m1l = h$ret1;
+ var m2h = h$mul2Word32(ql, bh); var m2l = h$ret1;
+ var qbs = m1h + m2l; // high word sum; may overflow uint32
+ var qbh = qbs >>> 0;
+ var qbl = m1l;
+
+ // At most 1 decrease: if ql*b > a, subtract b and decrement ql.
+ // Subtracting b from the (possibly truncated) 64-bit product gives
+ // exactly (ql-1)*b because (ql-1)*b < 2^64.
+ //
+ // ql*b is a 96-bit value spread over m2h (bits 95-64), qbh (63-32),
+ // qbl (31-0). The condition has four sub-cases:
+ // m2h > 0 : ql*b >= 2^64 > a (overflow into bits above 64)
+ // qbs > 4294967295 : m1h+m2l overflows 32 bits, so ql*b >= 2^64 > a
+ // (qbs is a JS double so the overflow is visible
+ // before the >>>0 truncation stored in qbh)
+ // qbh > ah : high words settle it; ql*b > a
+ // qbh === ah && qbl > al : high words tie; low words settle it
+ if (m2h > 0 || qbs > 4294967295 || qbh > ah || (qbh === ah && qbl > al)) {
+ ql = (ql - 1) >>> 0;
+ var dl = qbl - bl; qbl = dl >>> 0;
+ qbh = (qbh - bh - (dl !== qbl ? 1 : 0)) >>> 0;
+ }
+
+ // Remainder = a - ql*b
+ var drl = al - qbl;
+ rl = drl >>> 0;
+ rh = (ah - qbh - (drl !== rl ? 1 : 0)) >>> 0;
+
+ // At most 1 increase: if remainder >= b, subtract b and increment ql.
+ if (rh > bh || (rh === bh && rl >= bl)) {
+ ql = (ql + 1) >>> 0;
+ var drl2 = rl - bl;
+ rl = drl2 >>> 0;
+ rh = (rh - bh - (drl2 !== rl ? 1 : 0)) >>> 0;
+ }
+ }
+ h$ret1 = ql; h$ret2 = rh; h$ret3 = rl;
+ return qh;
+}
+
function h$hs_quotWord64(h1,l1,h2,l2) {
- var a = W64(h1,l1);
- var b = W64(h2,l2);
- var r = BigInt.asUintN(64, a / b);
- TRACE_ARITH("Word64: " + a + " / " + b + " ==> " + r)
- RETURN_W64(r);
+ var qh = h$quotRemWord64(h1>>>0,l1>>>0,h2>>>0,l2>>>0);
+ var ql = h$ret1;
+ TRACE_ARITH("Word64: " + W64(h1,l1) + " / " + W64(h2,l2) + " ==> " + W64(qh,ql))
+ RETURN_UBX_TUP2(qh,ql);
}
function h$hs_remWord64(h1,l1,h2,l2) {
- var a = W64(h1,l1);
- var b = W64(h2,l2);
- var r = BigInt.asUintN(64, a % b);
- TRACE_ARITH("Word64: " + a + " % " + b + " ==> " + r)
- RETURN_W64(r);
+ h$quotRemWord64(h1>>>0,l1>>>0,h2>>>0,l2>>>0);
+ var rh = h$ret2, rl = h$ret3;
+ TRACE_ARITH("Word64: " + W64(h1,l1) + " % " + W64(h2,l2) + " ==> " + W64(rh,rl))
+ RETURN_UBX_TUP2(rh,rl);
}
function h$hs_timesWord64(h1,l1,h2,l2) {
@@ -84,19 +143,55 @@ function h$hs_timesInt64(h1,l1,h2,l2) {
}
function h$hs_quotInt64(h1,l1,h2,l2) {
- var a = I64(h1,l1);
- var b = I64(h2,l2);
- var r = BigInt.asIntN(64, a / b);
- TRACE_ARITH("Int64: " + a + " / " + b + " ==> " + r)
- RETURN_I64(r);
+ // Determine sign: result negative iff operands have different signs
+ var neg = (h1 < 0) !== (h2 < 0);
+ // Absolute value of (h1,l1)
+ var ah, al;
+ if (h1 >= 0) { ah = h1 >>> 0; al = l1 >>> 0; }
+ else { al = (-l1) >>> 0; ah = (al === 0 ? -h1 : ~h1) >>> 0; }
+ // Absolute value of (h2,l2)
+ var bh, bl;
+ if (h2 >= 0) { bh = h2 >>> 0; bl = l2 >>> 0; }
+ else { bl = (-l2) >>> 0; bh = (bl === 0 ? -h2 : ~h2) >>> 0; }
+ // Unsigned quotient
+ var qh = h$quotRemWord64(ah, al, bh, bl);
+ var ql = h$ret1;
+ // Apply sign
+ if (neg) {
+ var nql = (-ql) >>> 0;
+ var nqh = (nql === 0 ? -qh : ~qh) | 0;
+ TRACE_ARITH("Int64: " + I64(h1,l1) + " / " + I64(h2,l2) + " ==> " + I64(nqh,nql))
+ RETURN_UBX_TUP2(nqh, nql);
+ } else {
+ TRACE_ARITH("Int64: " + I64(h1,l1) + " / " + I64(h2,l2) + " ==> " + I64(qh|0,ql))
+ RETURN_UBX_TUP2(qh | 0, ql);
+ }
}
function h$hs_remInt64(h1,l1,h2,l2) {
- var a = I64(h1,l1);
- var b = I64(h2,l2);
- var r = BigInt.asIntN(64, a % b);
- TRACE_ARITH("Int64: " + a + " % " + b + " ==> " + r)
- RETURN_I64(r);
+ // Remainder sign follows dividend
+ var neg_a = h1 < 0;
+ // Absolute value of (h1,l1)
+ var ah, al;
+ if (h1 >= 0) { ah = h1 >>> 0; al = l1 >>> 0; }
+ else { al = (-l1) >>> 0; ah = (al === 0 ? -h1 : ~h1) >>> 0; }
+ // Absolute value of (h2,l2)
+ var bh, bl;
+ if (h2 >= 0) { bh = h2 >>> 0; bl = l2 >>> 0; }
+ else { bl = (-l2) >>> 0; bh = (bl === 0 ? -h2 : ~h2) >>> 0; }
+ // Unsigned remainder
+ h$quotRemWord64(ah, al, bh, bl);
+ var rh = h$ret2, rl = h$ret3;
+ // Apply sign of dividend
+ if (neg_a) {
+ var nrl = (-rl) >>> 0;
+ var nrh = (nrl === 0 ? -rh : ~rh) | 0;
+ TRACE_ARITH("Int64: " + I64(h1,l1) + " % " + I64(h2,l2) + " ==> " + I64(nrh,nrl))
+ RETURN_UBX_TUP2(nrh, nrl);
+ } else {
+ TRACE_ARITH("Int64: " + I64(h1,l1) + " % " + I64(h2,l2) + " ==> " + I64(rh|0,rl))
+ RETURN_UBX_TUP2(rh | 0, rl);
+ }
}
function h$hs_plusInt64(h1,l1,h2,l2) {
@@ -287,37 +382,44 @@ function h$mul2Word32(l1,l2) {
}
function h$quotWord32(n,d) {
- var a = W32(n);
- var b = W32(d);
- var r = BigInt.asUintN(32, a / b);
- TRACE_ARITH("Word32: " + a + " / " + b + " ==> " + r)
- RETURN_W32(r);
+ if ((d>>>0) === 0) throw new Error("divide by zero");
+ var r = Math.floor((n>>>0) / (d>>>0));
+ TRACE_ARITH("Word32: " + (n>>>0) + " / " + (d>>>0) + " ==> " + r)
+ return r;
}
function h$remWord32(n,d) {
- var a = W32(n);
- var b = W32(d);
- var r = BigInt.asUintN(32, a % b);
- TRACE_ARITH("Word32: " + a + " % " + b + " ==> " + r)
- RETURN_W32(r);
+ if ((d>>>0) === 0) throw new Error("divide by zero");
+ var r = (n>>>0) % (d>>>0);
+ TRACE_ARITH("Word32: " + (n>>>0) + " % " + (d>>>0) + " ==> " + r)
+ return r;
}
function h$quotRemWord32(n,d) {
- var a = W32(n);
- var b = W32(d);
- var q = BigInt.asUintN(32, a / b);
- var r = BigInt.asUintN(32, a % b);
- TRACE_ARITH("Word32: " + a + " `quotRem` " + b + " ==> (" + q + ", " + r + ")")
- RETURN_UBX_TUP2(Number(q),Number(r));
+ var nu = n>>>0, du = d>>>0;
+ if (du === 0) throw new Error("divide by zero");
+ var q = Math.floor(nu / du);
+ var r = nu % du;
+ TRACE_ARITH("Word32: " + nu + " `quotRem` " + du + " ==> (" + q + ", " + r + ")")
+ RETURN_UBX_TUP2(q, r);
}
+// Divide the 64-bit unsigned value (nh*2^32 + nl) by 32-bit unsigned d.
+// Precondition: quotient fits in 32 bits (nh < d).
function h$quotRem2Word32(nh,nl,d) {
- var a = W64(nh,nl);
- var b = W32(d);
- var q = BigInt.asUintN(32, a / b);
- var r = BigInt.asUintN(32, a % b);
- TRACE_ARITH("Word32: " + a + " `quotRem2` " + b + " ==> (" + q + ", " + r + ")")
- RETURN_UBX_TUP2(Number(q),Number(r));
+ var dv = d>>>0;
+ if (dv === 0) throw new Error("divide by zero");
+ var nh_u = nh>>>0;
+ // Long division in base 2^16 (all intermediate values <= 2^48, exact in double)
+ var a1 = nh_u * 65536 + ((nl>>>0) >>> 16);
+ var q1 = Math.floor(a1 / dv);
+ var r1 = a1 - q1 * dv;
+ var a2 = r1 * 65536 + ((nl>>>0) & 0xFFFF);
+ var q2 = Math.floor(a2 / dv);
+ var q = (q1 * 65536 + q2) >>> 0;
+ var r = (a2 - q2 * dv) >>> 0;
+ TRACE_ARITH("Word32: " + W64(nh,nl) + " `quotRem2` " + dv + " ==> (" + q + ", " + r + ")")
+ RETURN_UBX_TUP2(q, r);
}
function h$wordAdd2(l1,l2) {
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89d9ba37f3c5a954f6c84f9c336d407…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89d9ba37f3c5a954f6c84f9c336d407…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] ghci: serialize BCOByteArray buffer directly when possible
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2e22b43c by Cheng Shao at 2026-03-20T12:26:14-04:00
ghci: serialize BCOByteArray buffer directly when possible
This patch changes the `Binary` instances of `BCOByteArray` to
directly serialize the underlying buffer when possible, while also
taking into account the issue of host-dependent `Word` width. See
added comments and amended `Note [BCOByteArray serialization]` for
detailed explanation. Closes #27020.
- - - - -
2 changed files:
- libraries/ghci/GHCi/ResolvedBCO.hs
- testsuite/tests/ghci/should_run/BinaryArray.hs
Changes:
=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -9,17 +9,29 @@ module GHCi.ResolvedBCO
, mkBCOByteArray
) where
+#include "MachDeps.h"
+
import Prelude -- See note [Why do we import Prelude here?]
import GHC.Data.SizedSeq
import GHCi.RemoteTypes
import GHCi.BreakArray
-import Data.Binary
+#if SIZEOF_HSWORD == 4
+import Control.Monad
+import Data.Array.Base (foldrArray, listArray)
+import Data.ByteString.Builder.Extra
+import Foreign.Storable
+#endif
+
+import Data.Binary (Binary(..))
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.ByteString.Short (ShortByteString(..))
+import Data.Word
import GHC.Generics
-import Foreign.Storable
import GHC.Exts
-import Data.Array.Base (IArray, UArray(..))
+import Data.Array.Base (UArray(..))
#include "MachDeps.h"
@@ -58,15 +70,27 @@ data BCOByteArray a
getBCOByteArray :: !ByteArray#
}
+#if SIZEOF_HSWORD == 4
fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
where
len# = sizeofByteArray# ba#
n = (I# len#) `div` sizeOf (undefined :: a)
+#endif
mkBCOByteArray :: UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
+-- | Directly serialize 'BCOByteArray' payload without iterating over
+-- individual elements, assuming 'BCOByteArray' element type is a
+-- fixed-width type like 'Word16' that doesn't depend on host word
+-- size. See Note [BCOByteArray serialization] for more explanation.
+unsafePutFixedWidthBCOByteArray :: BCOByteArray a -> Put
+unsafePutFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba#
+
+unsafeGetFixedWidthBCOByteArray :: Get (BCOByteArray a)
+unsafeGetFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get
+
instance Show (BCOByteArray Word16) where
showsPrec _ _ = showString "BCOByteArray Word16"
@@ -89,10 +113,46 @@ instance Binary ResolvedBCO where
get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
-- See Note [BCOByteArray serialization]
-instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where
- put = put . fromBCOByteArray
- get = mkBCOByteArray <$> get
-
+instance Binary (BCOByteArray Word16) where
+ put = unsafePutFixedWidthBCOByteArray
+ get = unsafeGetFixedWidthBCOByteArray
+
+-- Word size depends on host, which is tricky when host/target word
+-- sizes differ. We always serialize `BCOByteArray Word` as
+-- `BCOByteArray Word64`.
+instance Binary (BCOByteArray Word) where
+#if SIZEOF_HSWORD == 8
+ -- 64-bit fast path. `BCOByteArray` is directly serialized via the
+ -- `Binary ShortByteString` instance, which serializes the `Int`
+ -- bytelength first (via `Int64` transparently), then copies the
+ -- buffer.
+ put = unsafePutFixedWidthBCOByteArray
+
+ get = unsafeGetFixedWidthBCOByteArray
+#else
+ -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle
+ -- the bytelength & buffer elements directly.
+ --
+ -- Regarding endianness: the bytelength is serialized via the
+ -- `Binary Int` instance, which is serialized as `Int64` via
+ -- big-endian. The payload follows host-endianness. This doesn't
+ -- work when host/target has different endianness, but we don't
+ -- support that setup yet anyway.
+ put ba32@(BCOByteArray ba32#) =
+ put len64 *>
+ putBuilder
+ (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32)
+ where
+ len32# = sizeofByteArray# ba32#
+ len64 = I# len32# * 2
+ arr32 = fromBCOByteArray ba32
+
+ get = do
+ len64 <- get
+ let len = len64 `div` 8
+ w32s <- replicateM len (fromIntegral <$> getWord64host)
+ pure $ mkBCOByteArray $ listArray (0, len - 1) w32s
+#endif
data ResolvedBCOPtr
= ResolvedBCORef {-# UNPACK #-} !Int
@@ -124,12 +184,17 @@ instance Binary ResolvedBCOPtr
-- The root issue here is the usage of platform sized integer types in
-- BCO (and any messages we pass between ghc/iserv really), we should
-- do what we already do for RemotePtr: always use Word64 instead of
--- Word. But that takes much more work, and there's an easier
--- mitigation: keep BCOByteArray as ByteArray#, but serialize it as
--- UArray, given the Binary instances are independent of platform word
--- size and endianness, so each Word/Int is always serialized as
--- 64-bit big-endian Word64/Int64, and the entire UArray is serialized
--- as a list (length+elements).
+-- Word.
+--
+-- When we serialize `BCOByteArray Word16`, element is fixed width on
+-- 32/64-bit host, so we can directly serialize the buffer per se. For
+-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray
+-- Word64`, and hence it has fast-path/slow-path decided at
+-- compile-time, see comments of `instance Binary (BCOByteArray Word)`
+-- for explanation. These are the only two `Binary` instances we ever
+-- use, so to avoid unnecessary complexity, we're fine with flexible
+-- instances here, instead of generalizing to any element type that
+-- may be fixed-width or not.
--
-- Since we erase the metadata in UArray, we need to find a way to
-- calculate the item count by dividing the ByteArray# length with
=====================================
testsuite/tests/ghci/should_run/BinaryArray.hs
=====================================
@@ -24,7 +24,7 @@ roundtripTest arr =
Left _ -> putStrLn "deserialization failed"
-- See Note [BCOByteArray serialization]
-roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a)
+roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a))
=> UArray Int a -> IO ()
roundtripTestByteArray (UArray _ _ _ arr#) =
let val = BCOByteArray arr# :: BCOByteArray a
@@ -44,10 +44,5 @@ main = do
roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
- roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int)
roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
- roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8)
roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)
- roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32)
- roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64)
- roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e22b43ca649e2cbe2ed221c4563b3d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e22b43ca649e2cbe2ed221c4563b3d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] bytecode: Carefully SLIDE off the end of a stack chunk
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
72b20fc0 by Luite Stegeman at 2026-03-20T12:25:30-04:00
bytecode: Carefully SLIDE off the end of a stack chunk
The SLIDE bytecode instruction was not checking for stack chunk
boundaries and could corrupt the stack underflow frame, leading
to crashes.
We add a check to use safe writes if we cross the chunk boundary
and also handle stack underflow if Sp is advanced past the underflow
frame.
fix #27001
- - - - -
4 changed files:
- rts/Interpreter.c
- + testsuite/tests/bytecode/T27001.hs
- + testsuite/tests/bytecode/T27001.stdout
- testsuite/tests/bytecode/all.T
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -271,6 +271,24 @@ See also Note [Width of parameters] for some more motivation.
#define WITHIN_CHUNK_BOUNDS_W(n, s) \
(RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+/* Note [Checking for underflow frames]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ We look at the stack slot at offset sizeof(StgUnderflowFrame) from
+ the start of the chunk to check if we're in the first check chunk.
+ Every non-first stack chunk has an underflow frame header at that offset.
+
+ We really should change this check, since this stack slot in the first
+ chunk may not be the start of a stack frame and could in theory contain
+ an arbitrary value.
+
+ In practice we're unlikely to have interpreted frames that low on the stack.
+ */
+#define IS_UNDERFLOW_FRAME(info) \
+ ((info) == &stg_stack_underflow_frame_d_info || \
+ (info) == &stg_stack_underflow_frame_v16_info || \
+ (info) == &stg_stack_underflow_frame_v32_info || \
+ (info) == &stg_stack_underflow_frame_v64_info)
#define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord)))
@@ -681,11 +699,9 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size
- sizeofW(StgUnderflowFrame));
- // 2a. Check it is an underflow frame (the top stack chunk won't have one).
- if( frame->info == &stg_stack_underflow_frame_d_info
- || frame->info == &stg_stack_underflow_frame_v16_info
- || frame->info == &stg_stack_underflow_frame_v32_info
- || frame->info == &stg_stack_underflow_frame_v64_info )
+ // 2a. Check it is an underflow frame (the first stack chunk won't have one).
+ // See Note [Checking for underflow frames]
+ if( IS_UNDERFLOW_FRAME(frame->info) )
{
INTERP_TICK(it_underflow_lookups);
@@ -702,9 +718,11 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
}
// 2b. Access the element if there is no underflow frame, it must be right
// at the top of the stack.
- else {
- // Not actually in the underflow case
+ else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) {
+ // Still inside the stack chunk
return Sp_plusW(offset_words);
+ } else {
+ barf("slow_spw: offset_words %d is out of bounds", (int)offset_words);
}
}
}
@@ -2425,8 +2443,39 @@ run_BCO:
* =>
* a_1 ... a_n, k
*/
- while(n-- > 0) {
- SpW(n+by) = ReadSpW(n);
+ if (n == 0 || WITHIN_CAP_CHUNK_BOUNDS_W(n - 1 + by)) {
+ while(n-- > 0) {
+ SpW(n+by) = ReadSpW(n);
+ }
+ } else {
+ // We write across a chunk boundary: Use safe access
+ while(n-- > 0) {
+ *((StgWord*)SafeSpWP(n+by)) = ReadSpW(n);
+ }
+ }
+
+ // If we SLIDE Sp past the chunk bounds we need to handle the underflow
+ // (possibly multiple times)
+ while (!WITHIN_CAP_CHUNK_BOUNDS_W(by)) {
+ StgStack *stk = cap->r.rCurrentTSO->stackobj;
+ StgUnderflowFrame *uf = (StgUnderflowFrame*)
+ (stk->stack + stk->stack_size
+ - sizeofW(StgUnderflowFrame));
+ // See Note [Checking for underflow frames]
+ if (IS_UNDERFLOW_FRAME(uf->info)) {
+ W_ sp_to_uf = (StgWord*)uf - (StgWord*)Sp;
+ Sp = (StgPtr)uf;
+ SAVE_STACK_POINTERS;
+ threadStackUnderflow(cap, cap->r.rCurrentTSO);
+ LOAD_STACK_POINTERS;
+ by -= sp_to_uf;
+ } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) {
+ // we're within the first stack chunk, this chunk has
+ // no underflow frame
+ break;
+ } else {
+ barf("bci_SLIDE: Sp+by outside stack bounds");
+ }
}
Sp_addW(by);
INTERP_TICK(it_slides);
=====================================
testsuite/tests/bytecode/T27001.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
+-- Test that SLIDE works correctly when it crosses a stack chunk boundary.
+-- See #27001.
+module Main where
+
+go :: Int -> Double -> Double
+go 0 !acc = acc
+go n !acc = go (n - 1) (acc + 1.0)
+
+result :: Double
+result = go 100000 0.0
+
+main :: IO ()
+main = print result
=====================================
testsuite/tests/bytecode/T27001.stdout
=====================================
@@ -0,0 +1 @@
+100000.0
=====================================
testsuite/tests/bytecode/all.T
=====================================
@@ -12,3 +12,8 @@ test('T26640', extra_files(["T26640.hs"]), ghci_script, ['T26640.script'])
# Nullary data constructors
test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script'])
+
+# SLIDE across stack chunk boundary (#27001)
+test('T27001', [extra_files(['T27001.hs']), req_interp],
+ run_command,
+ ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72b20fc0ad4b6ad12c67f686af5cb42…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72b20fc0ad4b6ad12c67f686af5cb42…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Move some functions related to pointer tagging to a separate module
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
1c50bd7b by Luite Stegeman at 2026-03-20T12:24:37-04:00
Move some functions related to pointer tagging to a separate module
- - - - -
bfd7aafd by Luite Stegeman at 2026-03-20T12:24:37-04:00
Branchless unpacking for enumeration types
Change unpacking for enumeration types to go to Word8#/Word16#/Word#
directly instead of going through an intermediate unboxed sum. This
allows us to do a branchless conversion using DataToTag and TagToEnum.
Fixes #26970
- - - - -
14 changed files:
- compiler/GHC/Cmm/Utils.hs
- + compiler/GHC/Platform/Tag.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/simplStg/should_run/all.T
- + testsuite/tests/simplStg/should_run/unpack_enum.hs
- + testsuite/tests/simplStg/should_run/unpack_enum.stdout
Changes:
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -41,7 +41,7 @@ module GHC.Cmm.Utils(
-- Tagging
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
- cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,
+ cmmConstrTag1,
-- Overlap and usage
regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn,
@@ -67,6 +67,7 @@ import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU )
import GHC.Platform
+import GHC.Platform.Tag (tAG_MASK)
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.BlockId
@@ -380,12 +381,6 @@ cmmMkAssign platform expr uq =
--
---------------------------------------------------
-tAG_MASK :: Platform -> Int
-tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
-
-mAX_PTR_TAG :: Platform -> Int
-mAX_PTR_TAG = tAG_MASK
-
-- Tag bits mask
cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)
=====================================
compiler/GHC/Platform/Tag.hs
=====================================
@@ -0,0 +1,47 @@
+-- | Dynamic pointer tagging
+--
+-- See Note [Data constructor dynamic tags]
+module GHC.Platform.Tag
+ ( DynTag
+ , tAG_MASK
+ , mAX_PTR_TAG
+ , isSmallFamily
+ ) where
+
+import GHC.Prelude
+
+import GHC.Platform
+
+-- | The tag on a pointer (from the dynamic-tagging paper)
+type DynTag = Int
+
+{- Note [Data constructor dynamic tags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The family size of a data type (the number of constructors
+or the arity of a function) can be either:
+ * small, if the family size < 2**tag_bits
+ * big, otherwise.
+
+Small families can have the constructor tag in the tag bits.
+Big families always use the tag values 1..mAX_PTR_TAG to represent
+evaluatedness, the last one lumping together all overflowing ones.
+We don't have very many tag bits: for example, we have 2 bits on
+x86-32 and 3 bits on x86-64.
+
+Also see Note [Tagging big families] in GHC.StgToCmm.Expr
+
+The interpreter also needs to be updated if we change the
+tagging strategy; see tagConstr in rts/Interpreter.c.
+-}
+
+-- | Tag bits mask / maximum pointer tag value, derived from the
+-- number of tag bits on the platform.
+tAG_MASK, mAX_PTR_TAG :: Platform -> Int
+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
+mAX_PTR_TAG = tAG_MASK
+
+-- | Is a data type family small enough that each constructor can get
+-- its own pointer tag?
+isSmallFamily :: Platform -> Int -> Bool
+isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -65,12 +65,12 @@ module GHC.StgToCmm.Closure (
import GHC.Prelude
import GHC.Platform
+import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily)
import GHC.Platform.Profile
import GHC.Stg.Syntax
import GHC.Runtime.Heap.Layout
import GHC.Cmm
-import GHC.Cmm.Utils
import GHC.StgToCmm.Types
import GHC.StgToCmm.Sequel
@@ -319,31 +319,6 @@ mkLFStringLit = LFUnlifted
-- Dynamic pointer tagging
-----------------------------------------------------
-type DynTag = Int -- The tag on a *pointer*
- -- (from the dynamic-tagging paper)
-
--- Note [Data constructor dynamic tags]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The family size of a data type (the number of constructors
--- or the arity of a function) can be either:
--- * small, if the family size < 2**tag_bits
--- * big, otherwise.
---
--- Small families can have the constructor tag in the tag bits.
--- Big families always use the tag values 1..mAX_PTR_TAG to represent
--- evaluatedness, the last one lumping together all overflowing ones.
--- We don't have very many tag bits: for example, we have 2 bits on
--- x86-32 and 3 bits on x86-64.
---
--- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
---
--- The interpreter also needs to be updated if we change the
--- tagging strategy; see tagConstr in rts/Interpreter.c.
-
-isSmallFamily :: Platform -> Int -> Bool
-isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
-
tagForCon :: Platform -> DataCon -> DynTag
tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform)
-- NB: 1-indexed
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -35,7 +35,8 @@ import GHC.Cmm.Graph
import GHC.Cmm.BlockId
import GHC.Cmm hiding ( succ )
import GHC.Cmm.Info
-import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG )
+import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit )
+import GHC.Platform.Tag ( mAX_PTR_TAG )
import GHC.Core
import GHC.Core.DataCon
import GHC.Types.ForeignCall
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Core.Class
import GHC.Core.Utils( mkCast )
import GHC.Core ( Expr(..), mkConApp )
-import GHC.StgToCmm.Closure ( isSmallFamily )
+import GHC.Platform.Tag ( isSmallFamily )
import GHC.Utils.Outputable
import GHC.Utils.Panic
=====================================
compiler/GHC/Tc/TyCl/Build.hs
=====================================
@@ -178,6 +178,7 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
+ ; platform <- getPlatform
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs
@@ -192,7 +193,7 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
(dc_rep, impl_bangs, str_marks) =
- initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
+ initUs_ us (mkDataConRep platform dc_bang_opts fam_envs wrap_name data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -95,6 +95,11 @@ import Data.List ( zipWith4 )
import GHC.StgToCmm.Types (LambdaFormInfo(..))
import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))
+import GHC.Builtin.PrimOps.Ids (primOpId)
+import GHC.Builtin.PrimOps (PrimOp(..))
+import GHC.Platform (Platform)
+import GHC.Platform.Tag (isSmallFamily)
+
{-
************************************************************************
* *
@@ -783,12 +788,13 @@ data BangOpts = BangOpts
, bang_opt_unbox_small :: !Bool -- ^ Unbox small strict fields
}
-mkDataConRep :: DataConBangOpts
+mkDataConRep :: Platform
+ -> DataConBangOpts
-> FamInstEnvs
-> Name
-> DataCon
-> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
-mkDataConRep dc_bang_opts fam_envs wrap_name data_con
+mkDataConRep platform dc_bang_opts fam_envs wrap_name data_con
| not wrapper_reqd
= return (NoDataConRep, arg_ibangs, rep_strs)
@@ -905,12 +911,12 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- detect this later (see test T2334A)
| otherwise
= case dc_bang_opts of
- SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang bang_opts fam_envs)
+ SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang platform bang_opts fam_envs)
orig_arg_tys orig_bangs
FixedBangOpts bangs -> bangs
(rep_tys_w_strs, wrappers)
- = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
+ = unzip (zipWith (dataConArgRep platform) all_arg_tys (ev_ibangs ++ arg_ibangs))
(unboxers, boxers) = unzip wrappers
(rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
@@ -1149,24 +1155,25 @@ newLocal name_stem (Scaled w ty) =
-- never on the field of a newtype constructor.
-- See @Note [HsImplBangs for newtypes]@.
dataConSrcToImplBang
- :: BangOpts
+ :: Platform
+ -> BangOpts
-> FamInstEnvs
-> Scaled Type
-> HsSrcBang
-> HsImplBang
-dataConSrcToImplBang bang_opts fam_envs arg_ty
+dataConSrcToImplBang platform bang_opts fam_envs arg_ty
(HsSrcBang ann unpk NoSrcStrict)
| bang_opt_strict_data bang_opts -- StrictData => strict field
- = dataConSrcToImplBang bang_opts fam_envs arg_ty
+ = dataConSrcToImplBang platform bang_opts fam_envs arg_ty
(HsSrcBang ann unpk SrcStrict)
| otherwise -- no StrictData => lazy field
= HsLazy
-dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
+dataConSrcToImplBang _ _ _ _ (HsSrcBang _ _ SrcLazy)
= HsLazy
-dataConSrcToImplBang bang_opts fam_envs arg_ty
+dataConSrcToImplBang platform bang_opts fam_envs arg_ty
(HsSrcBang _ unpk_prag SrcStrict)
| isUnliftedType (scaledThing arg_ty)
-- NB: non-newtype data constructors can't have representation-polymorphic fields
@@ -1179,7 +1186,7 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
arg_ty' = case mb_co of
{ Just redn -> scaledSet arg_ty (reductionReducedType redn)
; Nothing -> arg_ty }
- , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty'
+ , shouldUnpackArgTy platform bang_opts unpk_prag fam_envs arg_ty'
= if bang_opt_unbox_disable bang_opts
then HsStrict True -- Not unpacking because of -O0
-- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
@@ -1193,23 +1200,24 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
-- | Wrappers/Workers and representation following Unpack/Strictness
-- decisions
dataConArgRep
- :: Scaled Type
+ :: Platform
+ -> Scaled Type
-> HsImplBang
-> ([(Scaled Type,StrictnessMark)] -- Rep types
,(Unboxer,Boxer))
-dataConArgRep arg_ty HsLazy
+dataConArgRep _ arg_ty HsLazy
= ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
-dataConArgRep arg_ty (HsStrict _)
+dataConArgRep _ arg_ty (HsStrict _)
= ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG
-dataConArgRep arg_ty (HsUnpack Nothing)
- = dataConArgUnpack arg_ty
+dataConArgRep platform arg_ty (HsUnpack Nothing)
+ = dataConArgUnpack platform arg_ty
-dataConArgRep (Scaled w _) (HsUnpack (Just co))
+dataConArgRep platform (Scaled w _) (HsUnpack (Just co))
| let co_rep_ty = coercionRKind co
- , (rep_tys, wrappers) <- dataConArgUnpack (Scaled w co_rep_ty)
+ , (rep_tys, wrappers) <- dataConArgUnpack platform (Scaled w co_rep_ty)
= (rep_tys, wrapCo co co_rep_ty wrappers)
@@ -1334,19 +1342,92 @@ problem entirely by treating sums and products differently here.
-}
dataConArgUnpack
- :: Scaled Type
+ :: Platform
+ -> Scaled Type
-> ( [(Scaled Type, StrictnessMark)] -- Rep types
, (Unboxer, Boxer) )
-dataConArgUnpack scaledTy@(Scaled _ arg_ty)
+dataConArgUnpack platform scaledTy@(Scaled _ arg_ty)
| Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
= assert (not (isNewTyCon tc)) $
case tyConDataCons tc of
[con] -> dataConArgUnpackProduct scaledTy tc_args con
+ cons | all (null . dataConOrigArgTys) cons
+ -> dataConArgUnpackEnum platform scaledTy tc_args cons
cons -> dataConArgUnpackSum scaledTy tc_args cons
| otherwise
= pprPanic "dataConArgUnpack" (ppr arg_ty)
-- An interface file specified Unpacked, but we couldn't unpack it
+{- Note [UNPACK for enum types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When a strict field has an enumeration type (all constructors are nullary),
+we unpack it to a single narrow primitive word rather than an unboxed sum.
+
+For example, given:
+ data Color = Red | Green | Blue
+ data Foo = MkFoo {-# UNPACK #-} !Color
+
+the worker for MkFoo will have a Word8# field.
+
+Avoiding the intermediate unboxed sum allows us to use branchless conversion
+operations DataToTag and TagToEnum.
+-}
+
+dataConArgUnpackEnum
+ :: Platform
+ -> Scaled Type
+ -> [Type]
+ -> [DataCon]
+ -> ( [(Scaled Type, StrictnessMark)] -- Rep types
+ , (Unboxer, Boxer) )
+dataConArgUnpackEnum platform (Scaled arg_mult ty) _tc_args cons =
+ ( [ (scaled_enum_ty, MarkedStrict) ] -- See Note [UNPACK for enum types]
+ , ( unboxer, boxer ) )
+ where
+ !enum_sum_arity = length cons
+ conv op e = App (Var (primOpId op)) e
+
+ conv_tag_levpoly op e = App (mkTyApps (Var (primOpId op)) [getLevity ty, ty]) e
+
+ (enum_ty, unbox_convert, box_convert)
+ | enum_sum_arity < 256 = (word8PrimTy, conv WordToWord8Op, conv Word8ToWordOp)
+ | enum_sum_arity < 65536 = (word16PrimTy, conv WordToWord16Op, conv Word16ToWordOp)
+ | otherwise = (wordPrimTy, id, id)
+ scaled_enum_ty = Scaled arg_mult enum_ty
+
+ datatotag_op
+ | isSmallFamily platform enum_sum_arity = DataToTagSmallOp
+ | otherwise = DataToTagLargeOp
+
+ -- Tags are 1-based: add 1 to 0-based DataToTag result
+ add_one e = App (App (Var (primOpId IntAddOp)) e)
+ (Lit (LitNumber LitNumInt 1))
+ -- Subtract 1 to convert back to 0-based for TagToEnum
+ sub_one e = App (App (Var (primOpId IntSubOp)) e)
+ (Lit (LitNumber LitNumInt 1))
+
+ unboxer v = do enum_rep_id <- newLocal (fsLit "unbx_enum") scaled_enum_ty
+ let unbox_fn body
+ = mkSingleAltCase
+ (unbox_convert (App (Var (primOpId IntToWordOp))
+ (add_one (conv_tag_levpoly datatotag_op (Var v)))))
+ enum_rep_id
+ DEFAULT
+ []
+ body
+ return ([enum_rep_id], unbox_fn)
+
+ boxer = Boxer $ \ subst -> do
+ let ty' = TcType.substTyUnchecked subst ty
+ conv_tag' op e = App (mkTyApps (Var (primOpId op)) [ty']) e
+ enum_rep_id <- newLocal (fsLit "bx_enum")
+ (TcType.substScaledTyUnchecked subst scaled_enum_ty)
+ let box_fn = conv_tag'
+ TagToEnumOp
+ (sub_one (App (Var (primOpId WordToIntOp))
+ (box_convert (Var enum_rep_id))))
+ return ([enum_rep_id], box_fn)
+
dataConArgUnpackProduct
:: Scaled Type
-> [Type]
@@ -1452,13 +1533,13 @@ mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy [ty] = ty
mkUbxSumAltTy tys = mkTupleTy Unboxed tys
-shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
+shouldUnpackArgTy :: Platform -> BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
-- True if we ought to unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
-shouldUnpackArgTy bang_opts prag fam_envs arg_ty
+shouldUnpackArgTy platform bang_opts prag fam_envs arg_ty
| Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)
, all ok_con data_cons -- Returns True only if we can't get a
-- loop involving these data cons
@@ -1534,7 +1615,7 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty
|| (bang_opt_unbox_small bang_opts
&& is_small_rep) -- See Note [Unpack one-wide fields]
where
- (rep_tys, _) = dataConArgUnpack arg_ty
+ (rep_tys, _) = dataConArgUnpack platform arg_ty
-- Takes in the list of reps used to represent the dataCon after it's unpacked
-- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -228,7 +228,7 @@ ubxSumRepType constrs0
rep :: [PrimRep] -> SortedSlotTys
rep ty = sort (map primRepSlot ty)
- -- constructors start at 1, pick an appropriate slot size for the tag
+ -- constructors are 1-based, pick an appropriate slot size for the tag
tag_slot | length constrs0 < 256 = Word8Slot
| length constrs0 < 65536 = Word16Slot
-- we use 2147483647 instead of 4294967296 to avoid
=====================================
compiler/ghc.cabal.in
=====================================
@@ -675,6 +675,7 @@ Library
GHC.Platform.NoRegs
GHC.Platform.PPC
GHC.Platform.Profile
+ GHC.Platform.Tag
GHC.Platform.Reg
GHC.Platform.Reg.Class
GHC.Platform.Reg.Class.NoVectors
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -1,6 +1,7 @@
Found Language.Haskell.Syntax module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
+GHC.Builtin.PrimOps.Ids
GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
@@ -8,6 +9,7 @@ GHC.Builtin.Uniques
GHC.Cmm.BlockId
GHC.Cmm.CLabel
GHC.Cmm.Dataflow.Label
+GHC.Cmm.MachOp
GHC.Cmm.Type
GHC.CmmToAsm.CFG.Weight
GHC.Core
@@ -21,10 +23,12 @@ GHC.Core.FVs
GHC.Core.FamInstEnv
GHC.Core.InstEnv
GHC.Core.Make
+GHC.Core.Map.Expr
GHC.Core.Map.Type
GHC.Core.Multiplicity
GHC.Core.Opt.Arity
GHC.Core.Opt.CallerCC.Types
+GHC.Core.Opt.ConstantFold
GHC.Core.Opt.OccurAnal
GHC.Core.PatSyn
GHC.Core.Ppr
@@ -118,6 +122,7 @@ GHC.Parser.Errors.Basic
GHC.Platform
GHC.Platform.Constants
GHC.Platform.Profile
+GHC.Platform.Tag
GHC.Platform.Ways
GHC.Prelude
GHC.Prelude.Basic
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -1,6 +1,7 @@
Found GHC.Parser module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
+GHC.Builtin.PrimOps.Ids
GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
@@ -8,6 +9,7 @@ GHC.Builtin.Uniques
GHC.Cmm.BlockId
GHC.Cmm.CLabel
GHC.Cmm.Dataflow.Label
+GHC.Cmm.MachOp
GHC.Cmm.Type
GHC.CmmToAsm.CFG.Weight
GHC.Core
@@ -26,6 +28,7 @@ GHC.Core.Map.Type
GHC.Core.Multiplicity
GHC.Core.Opt.Arity
GHC.Core.Opt.CallerCC.Types
+GHC.Core.Opt.ConstantFold
GHC.Core.Opt.OccurAnal
GHC.Core.PatSyn
GHC.Core.Ppr
@@ -137,6 +140,7 @@ GHC.Parser.Types
GHC.Platform
GHC.Platform.Constants
GHC.Platform.Profile
+GHC.Platform.Tag
GHC.Platform.Ways
GHC.Prelude
GHC.Prelude.Basic
=====================================
testsuite/tests/simplStg/should_run/all.T
=====================================
@@ -20,4 +20,5 @@ test('T13536a',
test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])
-test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
\ No newline at end of file
+test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
+test('unpack_enum', normal, compile_and_run, [''])
\ No newline at end of file
=====================================
testsuite/tests/simplStg/should_run/unpack_enum.hs
=====================================
@@ -0,0 +1,206 @@
+{-# LANGUAGE MagicHash #-}
+
+-- | Test branchless enum unboxing.
+-- See Note [UNPACK for enum types] in GHC.Types.Id.Make.
+--
+-- When a strict field has an enumeration type (all nullary constructors),
+-- it should be unpacked to a single narrow primitive word (Word8#, Word16#,
+-- or Word#) rather than an unboxed sum, using dataToTag#/tagToEnum# for
+-- branchless conversion.
+
+module Main where
+
+import GHC.Exts.Heap.Closures (closureSize, asBox)
+import Control.Exception (evaluate)
+
+------------------------------------------------------------
+-- Small enum (2 constructors, like Bool)
+------------------------------------------------------------
+
+data Toggle = Off | On
+ deriving (Show, Eq)
+
+data BoxToggle = BoxToggle {-# UNPACK #-} !Toggle
+ {-# UNPACK #-} !Toggle
+ deriving (Show)
+
+------------------------------------------------------------
+-- Medium enum (5 constructors)
+------------------------------------------------------------
+
+data Color = Red | Green | Blue | Yellow | Purple
+ deriving (Show, Eq)
+
+data BoxColor = BoxColor {-# UNPACK #-} !Color
+ {-# UNPACK #-} !Color
+ deriving (Show)
+
+------------------------------------------------------------
+-- Phantom type parameter enum
+-- Tests that the boxer correctly substitutes type variables.
+------------------------------------------------------------
+
+data Proxy a = PA | PB | PC
+ deriving (Show, Eq)
+
+data BoxProxy = BoxProxy {-# UNPACK #-} !(Proxy Int)
+ {-# UNPACK #-} !(Proxy Char)
+ deriving (Show)
+
+------------------------------------------------------------
+-- Enum with exactly 255 constructors (boundary for Word8#)
+-- With 1-based tags, 255 constructors have tags 1-255 which
+-- fit in Word8#.
+------------------------------------------------------------
+
+data E255
+ = E255_0 | E255_1 | E255_2 | E255_3 | E255_4 | E255_5 | E255_6 | E255_7
+ | E255_8 | E255_9 | E255_10 | E255_11 | E255_12 | E255_13 | E255_14 | E255_15
+ | E255_16 | E255_17 | E255_18 | E255_19 | E255_20 | E255_21 | E255_22 | E255_23
+ | E255_24 | E255_25 | E255_26 | E255_27 | E255_28 | E255_29 | E255_30 | E255_31
+ | E255_32 | E255_33 | E255_34 | E255_35 | E255_36 | E255_37 | E255_38 | E255_39
+ | E255_40 | E255_41 | E255_42 | E255_43 | E255_44 | E255_45 | E255_46 | E255_47
+ | E255_48 | E255_49 | E255_50 | E255_51 | E255_52 | E255_53 | E255_54 | E255_55
+ | E255_56 | E255_57 | E255_58 | E255_59 | E255_60 | E255_61 | E255_62 | E255_63
+ | E255_64 | E255_65 | E255_66 | E255_67 | E255_68 | E255_69 | E255_70 | E255_71
+ | E255_72 | E255_73 | E255_74 | E255_75 | E255_76 | E255_77 | E255_78 | E255_79
+ | E255_80 | E255_81 | E255_82 | E255_83 | E255_84 | E255_85 | E255_86 | E255_87
+ | E255_88 | E255_89 | E255_90 | E255_91 | E255_92 | E255_93 | E255_94 | E255_95
+ | E255_96 | E255_97 | E255_98 | E255_99 | E255_100 | E255_101 | E255_102 | E255_103
+ | E255_104 | E255_105 | E255_106 | E255_107 | E255_108 | E255_109 | E255_110 | E255_111
+ | E255_112 | E255_113 | E255_114 | E255_115 | E255_116 | E255_117 | E255_118 | E255_119
+ | E255_120 | E255_121 | E255_122 | E255_123 | E255_124 | E255_125 | E255_126 | E255_127
+ | E255_128 | E255_129 | E255_130 | E255_131 | E255_132 | E255_133 | E255_134 | E255_135
+ | E255_136 | E255_137 | E255_138 | E255_139 | E255_140 | E255_141 | E255_142 | E255_143
+ | E255_144 | E255_145 | E255_146 | E255_147 | E255_148 | E255_149 | E255_150 | E255_151
+ | E255_152 | E255_153 | E255_154 | E255_155 | E255_156 | E255_157 | E255_158 | E255_159
+ | E255_160 | E255_161 | E255_162 | E255_163 | E255_164 | E255_165 | E255_166 | E255_167
+ | E255_168 | E255_169 | E255_170 | E255_171 | E255_172 | E255_173 | E255_174 | E255_175
+ | E255_176 | E255_177 | E255_178 | E255_179 | E255_180 | E255_181 | E255_182 | E255_183
+ | E255_184 | E255_185 | E255_186 | E255_187 | E255_188 | E255_189 | E255_190 | E255_191
+ | E255_192 | E255_193 | E255_194 | E255_195 | E255_196 | E255_197 | E255_198 | E255_199
+ | E255_200 | E255_201 | E255_202 | E255_203 | E255_204 | E255_205 | E255_206 | E255_207
+ | E255_208 | E255_209 | E255_210 | E255_211 | E255_212 | E255_213 | E255_214 | E255_215
+ | E255_216 | E255_217 | E255_218 | E255_219 | E255_220 | E255_221 | E255_222 | E255_223
+ | E255_224 | E255_225 | E255_226 | E255_227 | E255_228 | E255_229 | E255_230 | E255_231
+ | E255_232 | E255_233 | E255_234 | E255_235 | E255_236 | E255_237 | E255_238 | E255_239
+ | E255_240 | E255_241 | E255_242 | E255_243 | E255_244 | E255_245 | E255_246 | E255_247
+ | E255_248 | E255_249 | E255_250 | E255_251 | E255_252 | E255_253 | E255_254
+ deriving (Show, Eq, Enum, Bounded)
+
+-- Two E255 fields should fit in a single word (2 x Word8# = 2 bytes),
+-- so the closure should be header (1 word) + 1 payload word = size 2.
+data BoxE255 = BoxE255 {-# UNPACK #-} !E255
+ {-# UNPACK #-} !E255
+ deriving (Show)
+
+------------------------------------------------------------
+-- Enum with exactly 256 constructors (just over Word8# boundary).
+-- With 1-based tags, tag 256 does not fit in Word8#,
+-- so this should use Word16# instead.
+------------------------------------------------------------
+
+data E256
+ = E256_0 | E256_1 | E256_2 | E256_3 | E256_4 | E256_5 | E256_6 | E256_7
+ | E256_8 | E256_9 | E256_10 | E256_11 | E256_12 | E256_13 | E256_14 | E256_15
+ | E256_16 | E256_17 | E256_18 | E256_19 | E256_20 | E256_21 | E256_22 | E256_23
+ | E256_24 | E256_25 | E256_26 | E256_27 | E256_28 | E256_29 | E256_30 | E256_31
+ | E256_32 | E256_33 | E256_34 | E256_35 | E256_36 | E256_37 | E256_38 | E256_39
+ | E256_40 | E256_41 | E256_42 | E256_43 | E256_44 | E256_45 | E256_46 | E256_47
+ | E256_48 | E256_49 | E256_50 | E256_51 | E256_52 | E256_53 | E256_54 | E256_55
+ | E256_56 | E256_57 | E256_58 | E256_59 | E256_60 | E256_61 | E256_62 | E256_63
+ | E256_64 | E256_65 | E256_66 | E256_67 | E256_68 | E256_69 | E256_70 | E256_71
+ | E256_72 | E256_73 | E256_74 | E256_75 | E256_76 | E256_77 | E256_78 | E256_79
+ | E256_80 | E256_81 | E256_82 | E256_83 | E256_84 | E256_85 | E256_86 | E256_87
+ | E256_88 | E256_89 | E256_90 | E256_91 | E256_92 | E256_93 | E256_94 | E256_95
+ | E256_96 | E256_97 | E256_98 | E256_99 | E256_100 | E256_101 | E256_102 | E256_103
+ | E256_104 | E256_105 | E256_106 | E256_107 | E256_108 | E256_109 | E256_110 | E256_111
+ | E256_112 | E256_113 | E256_114 | E256_115 | E256_116 | E256_117 | E256_118 | E256_119
+ | E256_120 | E256_121 | E256_122 | E256_123 | E256_124 | E256_125 | E256_126 | E256_127
+ | E256_128 | E256_129 | E256_130 | E256_131 | E256_132 | E256_133 | E256_134 | E256_135
+ | E256_136 | E256_137 | E256_138 | E256_139 | E256_140 | E256_141 | E256_142 | E256_143
+ | E256_144 | E256_145 | E256_146 | E256_147 | E256_148 | E256_149 | E256_150 | E256_151
+ | E256_152 | E256_153 | E256_154 | E256_155 | E256_156 | E256_157 | E256_158 | E256_159
+ | E256_160 | E256_161 | E256_162 | E256_163 | E256_164 | E256_165 | E256_166 | E256_167
+ | E256_168 | E256_169 | E256_170 | E256_171 | E256_172 | E256_173 | E256_174 | E256_175
+ | E256_176 | E256_177 | E256_178 | E256_179 | E256_180 | E256_181 | E256_182 | E256_183
+ | E256_184 | E256_185 | E256_186 | E256_187 | E256_188 | E256_189 | E256_190 | E256_191
+ | E256_192 | E256_193 | E256_194 | E256_195 | E256_196 | E256_197 | E256_198 | E256_199
+ | E256_200 | E256_201 | E256_202 | E256_203 | E256_204 | E256_205 | E256_206 | E256_207
+ | E256_208 | E256_209 | E256_210 | E256_211 | E256_212 | E256_213 | E256_214 | E256_215
+ | E256_216 | E256_217 | E256_218 | E256_219 | E256_220 | E256_221 | E256_222 | E256_223
+ | E256_224 | E256_225 | E256_226 | E256_227 | E256_228 | E256_229 | E256_230 | E256_231
+ | E256_232 | E256_233 | E256_234 | E256_235 | E256_236 | E256_237 | E256_238 | E256_239
+ | E256_240 | E256_241 | E256_242 | E256_243 | E256_244 | E256_245 | E256_246 | E256_247
+ | E256_248 | E256_249 | E256_250 | E256_251 | E256_252 | E256_253 | E256_254 | E256_255
+ deriving (Show, Eq, Enum, Bounded)
+
+data BoxE256 = BoxE256 {-# UNPACK #-} !E256
+ {-# UNPACK #-} !E256
+ deriving (Show)
+
+------------------------------------------------------------
+-- Boundary size comparison: 5 fields of E255 (Word8#) vs E256 (Word16#)
+-- With 5 fields, Word8# fits in fewer payload words than Word16#
+-- on all platforms, so we can verify the packing difference.
+------------------------------------------------------------
+
+data Box5xE255 = Box5xE255 {-# UNPACK #-} !E255
+ {-# UNPACK #-} !E255
+ {-# UNPACK #-} !E255
+ {-# UNPACK #-} !E255
+ {-# UNPACK #-} !E255
+
+data Box5xE256 = Box5xE256 {-# UNPACK #-} !E256
+ {-# UNPACK #-} !E256
+ {-# UNPACK #-} !E256
+ {-# UNPACK #-} !E256
+ {-# UNPACK #-} !E256
+
+------------------------------------------------------------
+-- Test helpers
+------------------------------------------------------------
+
+test :: Show a => String -> a -> IO ()
+test name value = do
+ putStrLn $ "### " ++ name
+ value' <- evaluate value
+ print value'
+ putStrLn ("size: " ++ show (closureSize $ asBox value'))
+ putStrLn ""
+
+main :: IO ()
+main = do
+ -- Small enum: all constructor combinations
+ test "toggle_off_off" (BoxToggle Off Off)
+ test "toggle_on_on" (BoxToggle On On)
+ test "toggle_off_on" (BoxToggle Off On)
+
+ -- Medium enum: first, last, and middle constructors
+ test "color_first" (BoxColor Red Red)
+ test "color_last" (BoxColor Purple Purple)
+ test "color_mixed" (BoxColor Green Yellow)
+
+ -- Phantom type parameter: tests boxer substitution
+ test "proxy" (BoxProxy PB PC)
+
+ -- 255-constructor enum (boundary): first and last tags
+ test "e255_first" (BoxE255 E255_0 E255_0)
+ test "e255_last" (BoxE255 E255_254 E255_254)
+ test "e255_mixed" (BoxE255 E255_0 E255_254)
+
+ -- 256-constructor enum (just over Word8# boundary): first, last, and mixed
+ test "e256_first" (BoxE256 E256_0 E256_0)
+ test "e256_last" (BoxE256 E256_255 E256_255)
+ test "e256_mixed" (BoxE256 E256_0 E256_255)
+
+ -- Boundary size comparison: E255 uses Word8# (1 byte per field),
+ -- E256 uses Word16# (2 bytes per field). With 5 fields, the Word16#
+ -- version needs more payload words than the Word8# version.
+ b255 <- evaluate (Box5xE255 E255_0 E255_127 E255_254 E255_0 E255_127)
+ b256 <- evaluate (Box5xE256 E256_0 E256_128 E256_255 E256_0 E256_128)
+ let s255 = closureSize (asBox b255)
+ let s256 = closureSize (asBox b256)
+ putStrLn "### boundary_size_check"
+ putStrLn $ "e256 (5 x Word16#) larger than e255 (5 x Word8#): " ++ show (s256 > s255)
+ putStrLn ""
=====================================
testsuite/tests/simplStg/should_run/unpack_enum.stdout
=====================================
@@ -0,0 +1,55 @@
+### toggle_off_off
+BoxToggle Off Off
+size: 2
+
+### toggle_on_on
+BoxToggle On On
+size: 2
+
+### toggle_off_on
+BoxToggle Off On
+size: 2
+
+### color_first
+BoxColor Red Red
+size: 2
+
+### color_last
+BoxColor Purple Purple
+size: 2
+
+### color_mixed
+BoxColor Green Yellow
+size: 2
+
+### proxy
+BoxProxy PB PC
+size: 2
+
+### e255_first
+BoxE255 E255_0 E255_0
+size: 2
+
+### e255_last
+BoxE255 E255_254 E255_254
+size: 2
+
+### e255_mixed
+BoxE255 E255_0 E255_254
+size: 2
+
+### e256_first
+BoxE256 E256_0 E256_0
+size: 2
+
+### e256_last
+BoxE256 E256_255 E256_255
+size: 2
+
+### e256_mixed
+BoxE256 E256_0 E256_255
+size: 2
+
+### boundary_size_check
+e256 (5 x Word16#) larger than e255 (5 x Word8#): True
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80e2dd4f084eff9cc857b31daf9ea2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80e2dd4f084eff9cc857b31daf9ea2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] compiler/ffi: Collapse void pointer chains in capi wrappers
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
80e2dd4f by Zubin Duggal at 2026-03-20T12:23:33-04:00
compiler/ffi: Collapse void pointer chains in capi wrappers
New gcc/clang treat -Wincompatible-pointer-types as an error by
default. Since C only allows implicit conversion from void*, not void**,
capi wrappers for functions taking e.g. abstract** would fail to compile
when the Haskell type Ptr (Ptr Abstract) was naively translated to void**.
Collapse nested void pointers to a single void* when the pointee type
has no known C representation.
Fixes #26852
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Foreign/C.hs
- + testsuite/tests/ffi/should_compile/T26852.h
- + testsuite/tests/ffi/should_compile/T26852.hs
- + testsuite/tests/ffi/should_compile/T26852.stderr
- testsuite/tests/ffi/should_compile/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -328,37 +328,68 @@ dsFCall fn_id co fcall mDeclHeader = do
toCName :: Id -> String
toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i)))
+{- Note [Collapsing void pointer chains]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When translating Haskell types like (Ptr (Ptr Abstract)) to C types for capi
+wrappers, where Abstract has no CType annotation, naively we would produce
+"void**". This is problematic because in C, only void* has implicit conversion
+to any pointer type.
+Modern compilers (gcc, clang) treat -Wincompatible-pointer-types as an error
+by default (#26852), causing compilation failures for capi wrappers.
+
+The fix is to collapse void pointer chains: whenever the inner type of a
+Ptr/FunPtr resolves to void (i.e. the Haskell type has no known C
+representation), we return void* instead of void**, void***, etc.
+This works because void* implicitly converts to any pointer type in C.
+
+Examples:
+ Ptr Abstract => void*
+ Ptr (Ptr Abstract) => void* (used to be void**)
+ Ptr (Ptr (Ptr Abstract)) => void*
+ Ptr (Ptr CInt) => int** (CInt has CType "int", don't collapse)
+-}
+
+-- | See Note [Collapsing void pointer chains]
toCType :: Type -> (Maybe (Header GhcTc), SDoc)
-toCType = f False
- where f voidOK t
- -- First, if we have (Ptr t) of (FunPtr t), then we need to
+toCType t = case f False t of
+ (mh, _, cType) -> (mh, cType)
+ where
+ -- The Bool in the return type indicates whether the C type is
+ -- "void" due to an unknown Haskell type (True = void-based).
+ f :: Bool -> Type -> (Maybe (Header GhcTc), Bool, SDoc)
+ f voidOK t
+ -- First, if we have (Ptr t) or (FunPtr t), then we need to
-- convert t to a C type and put a * after it. If we don't
-- know a type for t, then "void" is fine, though.
+ -- If the inner type is void-based, we collapse the pointer
+ -- chain to just "void*". See Note [Collapsing void pointer chains].
| Just (ptr, [t']) <- splitTyConApp_maybe t
, tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
= case f True t' of
- (mh, cType') ->
- (mh, cType' <> char '*')
+ (mh, True, _) ->
+ (mh, True, text "void*")
+ (mh, False, cType') ->
+ (mh, False, cType' <> char '*')
-- Otherwise, if we have a type constructor application, then
-- see if there is a C type associated with that constructor.
-- Note that we aren't looking through type synonyms or
-- anything, as it may be the synonym that is annotated.
| Just tycon <- tyConAppTyConPicky_maybe t
, Just (CType _ mHeader cType) <- tyConCType_maybe tycon
- = (mHeader, ftext cType)
+ = (mHeader, False, ftext cType)
-- If we don't know a C type for this type, then try looking
-- through one layer of type synonym etc.
| Just t' <- coreView t
= f voidOK t'
- -- Handle 'UnliftedFFITypes' argument
+ -- Handle 'UnliftedFFITypes' argument
| Just tyCon <- tyConAppTyConPicky_maybe t
, isPrimTyCon tyCon
, Just cType <- ppPrimTyConStgType tyCon
- = (Nothing, text cType)
+ = (Nothing, False, text cType)
-- Otherwise we don't know the C type. If we are allowing
-- void then return that; otherwise something has gone wrong.
- | voidOK = (Nothing, text "void")
+ | voidOK = (Nothing, True, text "void")
| otherwise
= pprPanic "toCType" (ppr t)
=====================================
testsuite/tests/ffi/should_compile/T26852.h
=====================================
@@ -0,0 +1,7 @@
+typedef struct abstract abstract;
+
+void blah(abstract** x);
+abstract** get_abstract(void);
+abstract*** get_abstract3(void);
+abstract* get_simple(void);
+int** get_int_pp(void);
=====================================
testsuite/tests/ffi/should_compile/T26852.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE CApiFFI #-}
+module T26852 where
+
+import Foreign.Ptr
+import Foreign.C.Types
+
+data Abstract
+
+foreign import capi "T26852.h blah"
+ c_blah :: Ptr (Ptr Abstract) -> IO ()
+
+foreign import capi "T26852.h get_abstract"
+ c_get_abstract :: IO (Ptr (Ptr Abstract))
+
+foreign import capi "T26852.h get_abstract3"
+ c_get_abstract3 :: IO (Ptr (Ptr (Ptr Abstract)))
+
+foreign import capi "T26852.h get_simple"
+ c_get_simple :: IO (Ptr Abstract)
+
+foreign import capi "T26852.h get_int_pp"
+ c_get_int_pp :: IO (Ptr (Ptr CInt))
=====================================
testsuite/tests/ffi/should_compile/T26852.stderr
=====================================
@@ -0,0 +1,18 @@
+
+==================== Foreign export header file ====================
+
+
+
+==================== Foreign export stubs ====================
+#include "T26852.h"
+int** ghczuwrapperZC0ZCmainZCT26852ZCgetzuintzupp(void) {return get_int_pp();}
+#include "T26852.h"
+void* ghczuwrapperZC1ZCmainZCT26852ZCgetzusimple(void) {return get_simple();}
+#include "T26852.h"
+void* ghczuwrapperZC2ZCmainZCT26852ZCgetzuabstract3(void) {return get_abstract3();}
+#include "T26852.h"
+void* ghczuwrapperZC3ZCmainZCT26852ZCgetzuabstract(void) {return get_abstract();}
+#include "T26852.h"
+void ghczuwrapperZC4ZCmainZCT26852ZCblah(void* a1) {blah(a1);}
+
+
=====================================
testsuite/tests/ffi/should_compile/all.T
=====================================
@@ -44,3 +44,4 @@ test('T22774', [unless(js_arch() or arch('wasm32'), expect_fail)], compile, ['']
test('T24034', normal, compile, [''])
test('T25255', normal, compile, ['-dppr-debug'])
+test('T26852', [when(js_arch(), skip), filter_stdout_lines(r'.*ghczuwrapper.*')], compile, ['-ddump-foreign'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/80e2dd4f084eff9cc857b31daf9ea2e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/80e2dd4f084eff9cc857b31daf9ea2e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Change representation of floating point literals
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7d4ef162 by Matthew Craven at 2026-03-20T12:22:47-04:00
Change representation of floating point literals
This commit changes the representation of floating point literals
throughough the compiler, in particular in Core and Cmm.
The Rational type is deficient for this purpose, dealing poorly
with NaN, +/-Infinity, and negative zero. Instead, the new module
GHC.Types.Literal.Floating uses the host Float/Double type to represent
NaNs, infinities and negative zero. It also contains a Rational
constructor, for the benefit of -fexcess-precision.
Other changes:
- Remove Note [negative zero] and related code
This also removes the restrictions on constant-folding of division
by zero, and should make any problems with NaN/Infinity more obvious.
- Use -0.0 as the additive identity for Core constant folding rules
for floating-point addition, fixing #21227.
- Manual worker-wrapper for GHC.Float.rationalToDouble. This is
intended to prevent the compiler's WW on this function from
interfering with constant-folding. This change means that we now
avoid allocating a box for the result of a 'realToFrac' call in
T10359.
- Combine floatDecodeOp and doubleDecodeOp.
This change also fixes a bug in doubleDecodeOp wherein it
would incorrectly produce an Int# instead of an Int64#
literal for the mantissa component with 64-bit targets.
- Use Float/Double for assembly immediates, and update the X86 and
PowerPC backends to properly handle special values such as NaN and
infinity.
- Allow 'rational_to' to handle zero denominators, fixing a
TODO in GHC.Core.Opt.ConstantFold.
Fixes #8364 #9811 #18897 #21227
Progress towards #26919
Metric Decrease:
T10359
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
-------------------------
Metric Decrease:
T1969
T5321FD
-------------------------
- - - - -
50 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Cmm/Expr.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Type.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/AArch64/Regs.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/LA64/Ppr.hs
- compiler/GHC/CmmToAsm/LA64/Regs.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/PPC/Regs.hs
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
- compiler/GHC/CmmToAsm/RV64/Regs.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Regs.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Lit.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Literal.hs
- compiler/GHC/Types/Literal.hs
- + compiler/GHC/Types/Literal/Floating.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- + testsuite/tests/codeGen/should_run/T21227.hs
- + testsuite/tests/codeGen/should_run/T21227.stdout
- + testsuite/tests/codeGen/should_run/T9811.hs
- + testsuite/tests/codeGen/should_run/T9811.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/numeric/should_run/T7014.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d4ef162a3b39df8a7b8d96e4031e82…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d4ef162a3b39df8a7b8d96e4031e82…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] rts: opportunistically grow the MutableByteArray# in-place in resizeMutableByteArray#
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
309d7e87 by Cheng Shao at 2026-03-20T12:21:53-04:00
rts: opportunistically grow the MutableByteArray# in-place in resizeMutableByteArray#
Following !15234, this patch improves `resizeMutableByteArray#` memory
efficiency by growing the `MutableByteArray#` in-place if possible,
addressing an old todo comment here. Also adds a new test case
`resizeMutableByteArrayInPlace` that stresses this behavior.
- - - - -
3 changed files:
- rts/PrimOps.cmm
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/resizeMutableByteArrayInPlace.hs
Changes:
=====================================
rts/PrimOps.cmm
=====================================
@@ -200,6 +200,26 @@ stg_isMutableByteArrayWeaklyPinnedzh ( gcptr mba )
* used to as the LDV profiler will essentially ignore arrays anyways.
*/
+/* Note [Resizing arrays in-place]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * We try to shrink or grow bd->free when resizing a MutableByteArray in-place,
+ * to reclaim or use slop space at the end of the current block and avoid
+ * unnecessary fragmentation/allocation.
+ *
+ * But we must guarantee that:
+ *
+ * 1. mba is already at the end of current block (check bd->free).
+ * Otherwise we can't move closures that come after it anyway.
+ * 2. It's a nursery block that belongs to the current Capability,
+ * so check rCurrentAlloc (used by allocateMightFail) or
+ * pinned_object_block (used by allocatePinned). There's also no
+ * point if it's an older generation block, the mutator won't
+ * allocate into those blocks anyway.
+ *
+ * If check fails, fall back to the conservative code path: just zero the slop
+ * and return when shrinking, or allocate a new array when growing.
+ */
+
// shrink size of MutableByteArray in-place
stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> State# s
@@ -212,20 +232,7 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
old_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(old_size);
new_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(new_size);
- // Try to shrink bd->free as well, to reclaim slop space at the end
- // of current block and avoid unnecessary fragmentation. But we
- // must guarantee that:
- //
- // 1. mba is already at the end of current block (check bd->free).
- // Otherwise we can't move closures that come after it anyway.
- // 2. It's a nursery block that belongs to the current Capability,
- // so check rCurrentAlloc (used by allocateMightFail) or
- // pinned_object_block (used by allocatePinned). There's also no
- // point if it's an older generation block, the mutator won't
- // allocate into those blocks anyway.
- //
- // If check fails, fall back to the conservative code path: just
- // zero the slop and return.
+ // See Note [Resizing arrays in-place]
bd = Bdescr(mba);
if (bdescr_free(bd) != mba + WDS(old_wds) ||
(bd != StgRegTable_rCurrentAlloc(BaseReg) && bd != Capability_pinned_object_block(MyCapability()))) {
@@ -258,20 +265,33 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)
{
+ W_ old_size, old_wds, new_wds, new_free;
+ W_ bd;
+
ASSERT(new_size `ge` 0);
- if (new_size <= StgArrBytes_bytes(mba)) {
+ old_size = StgArrBytes_bytes(mba);
+ if (new_size <= old_size) {
call stg_shrinkMutableByteArrayzh(mba, new_size);
return (mba);
+ }
+
+ bd = Bdescr(mba);
+ old_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(old_size);
+ new_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(new_size);
+ new_free = mba + WDS(new_wds);
+
+ // See Note [Resizing arrays in-place]
+ // we also need to check that we don't grow past the end of current block.
+ if (bdescr_free(bd) == mba + WDS(old_wds) &&
+ (bd == StgRegTable_rCurrentAlloc(BaseReg) || bd == Capability_pinned_object_block(MyCapability())) &&
+ new_free <= bdescr_start(bd) + (TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE)) {
+ bdescr_free(bd) = new_free;
+ StgArrBytes_bytes(mba) = new_size;
+ return (mba);
} else {
(P_ new_mba) = call stg_newByteArrayzh(new_size);
- // maybe at some point in the future we may be able to grow the
- // MBA in-place w/o copying if we know the space after the
- // current MBA is still available, as often we want to grow the
- // MBA shortly after we allocated the original MBA. So maybe no
- // further allocations have occurred by then.
-
// copy over old content
prim %memcpy(BYTE_ARR_CTS(new_mba), BYTE_ARR_CTS(mba),
StgArrBytes_bytes(mba), SIZEOF_W);
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -669,3 +669,5 @@ test('TimeoutQueue',
test('ClosureTable',
[req_c, only_ways(['normal', 'debug']), extra_files(['ClosureTable_c.c'])], compile_and_run,
['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
+
+test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
=====================================
testsuite/tests/rts/resizeMutableByteArrayInPlace.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Monad
+import GHC.Exts
+import GHC.IO
+
+-- Given newByteArray#/newPinnedByteArray#, iterate given number of
+-- rounds: first allocate a MutableByteArray# using the first size,
+-- then resize to the new size, then resize back
+{-# INLINE testResize #-}
+testResize :: (Int# -> State# RealWorld -> (# State# RealWorld, MutableByteArray# RealWorld #)) -> Int -> Int -> Int -> IO ()
+testResize alloc# rounds (I# sz0#) (I# sz1#) =
+ replicateM_ rounds $ IO $ \s0 -> case alloc# sz0# s0 of
+ (# s1, mba0# #) -> case resizeMutableByteArray# mba0# sz1# s1 of
+ (# s2, mba1# #) -> case resizeMutableByteArray# mba1# sz0# s2 of
+ (# s3, _ #) -> (# s3, () #)
+
+main :: IO ()
+main = do
+ testResize newByteArray# 100000 8 64
+ testResize newByteArray# 100000 64 8
+ testResize newPinnedByteArray# 100000 8 64
+ testResize newPinnedByteArray# 100000 64 8
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309d7e87fe3e4653cf1be3cab6c987f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309d7e87fe3e4653cf1be3cab6c987f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Improve incomplete record selector warnings
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
52c3e6ba by sheaf at 2026-03-20T12:21:09-04:00
Improve incomplete record selector warnings
This commit stops GHC from emitting spurious incomplete record selector
warnings for bare selectors/projections such as .fld
There are two places we currently emit incomplete record selector
warnings:
1. In the desugarer, when we see a record selector or an occurrence
of 'getField'. Here, we can use pattern matching information to
ensure we don't give false positives.
2. In the typechecker, which might sometimes give false positives but
can emit warnings in cases that the pattern match checker would
otherwise miss.
This is explained in Note [Detecting incomplete record selectors]
in GHC.HsToCore.Pmc.
Now, we obviously don't want to emit the same error twice, and generally
we prefer (1), as those messages contain fewer false positives. So we
suppress (2) when we are sure we are going to emit (1); the logic for
doing so is in GHC.Tc.Instance.Class.warnIncompleteRecSel,
and works by looking at the CtOrigin.
Now, the issue was that this logic handled explicit record selectors as
well as overloaded record field selectors such as "x.r" (which turns
into a simple GetFieldOrigin CtOrigin), but it didn't properly handle
record projectors like ".fld" or ".fld1.fld2" (which result in other
CtOrigins such as 'RecordFieldProjectionOrigin').
To solve this problem, we re-use the 'isHasFieldOrigin' introduced in
fbdc623a (slightly adjusted).
On the way, we also had to update the desugarer with special handling
for the 'ExpandedThingTc' case in 'ds_app', to make sure that
'ds_app_var' sees all the type arguments to 'getField' in order for it
to indeed emit warnings like in (1).
Fixes #26686
- - - - -
8 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/Origin.hs
- + testsuite/tests/overloadedrecflds/should_compile/T26686.hs
- + testsuite/tests/overloadedrecflds/should_compile/T26686.stderr
- testsuite/tests/overloadedrecflds/should_compile/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -721,6 +721,15 @@ ds_app (XExpr (ConLikeTc con)) _hs_args core_args
ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args
= ds_app_rec_sel sel_id sel_id core_args
+ds_app (XExpr (ExpandedThingTc _orig e)) hs_args core_args
+ = ds_app e hs_args core_args
+ -- NB: this is important for the 'getField' case of 'ds_app_var', which needs
+ -- to see all type arguments to 'getField' at once, while for record field
+ -- projections such as (.fld) we may get:
+ --
+ -- XExpr (ExpandedThingTc (.fld) (getField @Symbol @LiftedRep @LiftedRep "fld"))
+ -- `HsAppType` rec_ty `HsAppType` fld
+
ds_app (HsVar _ lfun) hs_args core_args
= ds_app_var lfun hs_args core_args
@@ -736,8 +745,10 @@ ds_app_var (L loc fun_id) hs_args core_args
-----------------------
-- Deal with getField applications. General form:
-- getField
- -- @GHC.Types.Symbol {k}
- -- @"sel" x_ty
+ -- @Symbol {k}
+ -- @LiftedRep {r_rep}
+ -- @LiftedRep {a_rep}
+ -- @"sel" fld
-- @T r_ty
-- @Int a_ty
-- ($dHasField :: HasField "sel" T Int) dict
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -375,6 +375,10 @@ Finally, there are two more items addressing -XOverloadedRecordDot:
the (IRS6) warning in the typechecker for a `HasField` constraint that
arises from a record-dot HsGetField occurrence. Happily, this is easy to do
by looking at its `CtOrigin`. Tested in T24891.
+
+ The same applies for record field projection operators such as (.fld) and
+ (.fld1.fld2), which have different 'CtOrigin's. The 'isHasFieldOrigin'
+ function catches those as well. Tested in T26686.
-}
pmcRecSel :: Id -- ^ Id of the selector
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -97,6 +97,7 @@ import Data.Ord ( comparing )
import Data.Either ( partitionEithers )
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
+import qualified Data.Semigroup as Semi
{-
************************************************************************
@@ -2714,15 +2715,34 @@ hasFieldInfo_maybe rdr_env fam_inst_envs item
-- (HF2e) It's a custom HasField constraint, not the one from GHC.Records.
| Just (tc, _) <- splitTyConApp_maybe (errorItemPred item)
- , getOccString tc == "HasField"
- , isHasFieldOrigin (errorItemOrigin item)
- = return $ Just $ CustomHasField tc
+ = do { rebindable_syntax <- xoptM LangExt.RebindableSyntax
+ ; return $
+ if want_custom_hasfield_msg tc rebindable_syntax
+ then Just $ CustomHasField tc
+ else Nothing
+ }
| otherwise
= return Nothing
where
+ orig = errorItemOrigin item
+
+ want_custom_hasfield_msg tc rebindable_syntax
+ | getOccString tc == "HasField"
+ = Semi.getAny $ foldMapCtOrigin (Semi.Any . is_has_field) orig
+ | otherwise
+ = False
+ where
+ -- Handle custom 'getField'/'setField' with RebindableSyntax.
+ is_has_field (OccurrenceOf n)
+ | rebindable_syntax
+ , getOccString n `elem` ["getField", "setField"]
+ = True
+ is_has_field o
+ = isHasFieldOrigin o
+
get_parent_nm :: Name -> TcM (Maybe (Either PatSyn TyCon))
get_parent_nm nm =
do { fld_id <- tcLookupId nm
@@ -2762,22 +2782,6 @@ hasField_maybe pred =
-- NB: we deliberately don't handle rebound 'HasField' (with -XRebindableSyntax),
-- as GHC only has built-in instances for the built-in 'HasField' class.
--- | Does this constraint arise from GHC internal mechanisms that desugar to
--- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)?
---
--- Just used heuristically to decide whether to print an informative message to
--- the user (see (H2e) in Note [Error messages for unsolved HasField constraints]).
-isHasFieldOrigin :: CtOrigin -> Bool
-isHasFieldOrigin = \case
- OccurrenceOf n ->
- -- A heuristic...
- getOccString n `elem` ["getField", "setField"]
- OccurrenceOfRecSel {} -> True
- RecordUpdOrigin {} -> True
- RecordFieldProjectionOrigin {} -> True
- GetFieldOrigin {} -> True
- _ -> False
-
-----------------------
-- relevantBindings looks at the value environment and finds values whose
-- types mention any of the offending type variables. It has to be
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.CtLoc
-import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
+import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, isHasFieldOrigin )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs )
import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
@@ -1275,8 +1275,8 @@ warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM ()
-- Warn about incomplete record selectors
-- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
warnIncompleteRecSel dflags sel_id ct_loc
- | not (isGetFieldOrigin (ctLocOrigin ct_loc))
- -- isGetFieldOrigin: see (IRS7) in
+ | not $ isHasFieldOrigin (ctLocOrigin ct_loc)
+ -- isHasFieldOrigin: see (IRS7) in
-- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
, RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id
, not (null fallible_cons)
@@ -1288,11 +1288,6 @@ warnIncompleteRecSel dflags sel_id ct_loc
where
maxCons = maxUncoveredPatterns dflags
- -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
- -- despite the expansion to (getField @"x" r)
- isGetFieldOrigin (GetFieldOrigin {}) = True
- isGetFieldOrigin _ = False
-
lookupHasFieldLabel
:: FamInstEnvs -> GlobalRdrEnv -> [Type]
-> Maybe ( Name -- Name of the record selector
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -16,7 +16,8 @@ module GHC.Tc.Types.Origin (
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, pprCtOriginBriefly, isGivenOrigin,
- defaultReprEqOrigins, isWantedSuperclassOrigin,
+ foldMapCtOrigin,
+ defaultReprEqOrigins, isWantedSuperclassOrigin, isHasFieldOrigin,
ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),
HsImplicitLiftSplice(..),
StandaloneDeriv,
@@ -52,6 +53,8 @@ import GHC.Tc.Utils.TcType
import GHC.Hs
+import GHC.Builtin.Names (getFieldName)
+
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
@@ -79,6 +82,8 @@ import GHC.Types.Unique.Supply
import qualified Data.Kind as Hs
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isNothing)
+import qualified Data.Semigroup as Semi
+import GHC.Generics
{- *********************************************************************
* *
@@ -993,6 +998,95 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms
pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")
pprNonLinearPatternReason OtherPatternReason = empty
+
+{- *********************************************************************
+* *
+ Recursing through CtOrigin
+* *
+********************************************************************* -}
+
+-- | Fold over a 'CtOrigin', looking through all recursive
+-- occurrences of 'CtOrigin' within 'CtOrigin'.
+foldMapCtOrigin :: forall m. Semigroup m => (CtOrigin -> m) -> CtOrigin -> m
+foldMapCtOrigin f = go
+ where
+ go :: CtOrigin -> m
+ go orig =
+ case orig of
+ KindEqOrigin _ _ o _ -> recur o
+ CycleBreakerOrigin o -> recur o
+ WantedSuperclassOrigin _ o -> recur o
+ DefaultReprEqOrigin _ _ o -> recur o
+ ScOrigin cls_or_qc _sc_flag ->
+ case cls_or_qc of
+ IsQC _ o -> recur o
+ IsClsInst -> f orig
+
+ -- Explicit pattern match on remaining constructors, in order to get
+ -- better pattern-match warnings when constructors are changed or
+ -- added/removed. This isn't entirely fool-proof, as someone may still
+ -- change the type of one of the fields and hide a 'CtOrigin' inside.
+ --
+ -- This approach was chosen instead of using 'syb'/'GHC.Generics',
+ -- because those would require deriving 'Data.Data'/'Generic' on
+ -- a huge number of datatypes.
+ GivenOrigin {} -> f orig
+ GivenSCOrigin {} -> f orig
+ OccurrenceOf {} -> f orig
+ OccurrenceOfRecSel {} -> f orig
+ AppOrigin {} -> f orig
+ SpecPragOrigin {} -> f orig
+ TypeEqOrigin {}-> f orig
+ IPOccOrigin {} -> f orig
+ OverLabelOrigin {} -> f orig
+ LiteralOrigin {} -> f orig
+ QualLiteralOrigin {} -> f orig
+ NegateOrigin {} -> f orig
+ ArithSeqOrigin {} -> f orig
+ AssocFamPatOrigin {} -> f orig
+ SectionOrigin {} -> f orig
+ GetFieldOrigin {} -> f orig
+ RecordFieldProjectionOrigin {} -> f orig
+ TupleOrigin {} -> f orig
+ ExprSigOrigin {} -> f orig
+ PatSigOrigin {} -> f orig
+ PatOrigin {} -> f orig
+ ProvCtxtOrigin {} -> f orig
+ RecordUpdOrigin {} -> f orig
+ ViewPatOrigin {} -> f orig
+ DerivOrigin {} -> f orig
+ DerivOriginDC {} -> f orig
+ DerivOriginCoerce {} -> f orig
+ DefaultOrigin {} -> f orig
+ DoOrigin {} -> f orig
+ DoPatOrigin {} -> f orig
+ MCompOrigin {} -> f orig
+ MCompPatOrigin {} -> f orig
+ ProcOrigin {} -> f orig
+ ArrowCmdOrigin {} -> f orig
+ AnnOrigin {} -> f orig
+ FunDepOrigin {} -> f orig
+ ExprHoleOrigin {} -> f orig
+ TypeHoleOrigin {} -> f orig
+ PatCheckOrigin {} -> f orig
+ ListOrigin {} -> f orig
+ IfThenElseOrigin {} -> f orig
+ BracketOrigin {} -> f orig
+ StaticOrigin {} -> f orig
+ ImpedanceMatching {} -> f orig
+ Shouldn'tHappenOrigin {} -> f orig
+ InstProvidedOrigin {} -> f orig
+ NonLinearPatternOrigin {} -> f orig
+ OmittedFieldOrigin {} -> f orig
+ UsageEnvironmentOf {} -> f orig
+ FRROrigin {} -> f orig
+ InstanceSigOrigin {} -> f orig
+ AmbiguityCheckOrigin {} -> f orig
+ ImplicitLiftOrigin {} -> f orig
+
+ where
+ recur o = f orig Semi.<> go o
+
{- *********************************************************************
* *
Defaulting of representational equalities
@@ -1004,21 +1098,10 @@ pprNonLinearPatternReason OtherPatternReason = empty
-- That is, this function extracts all occurrences of the 'DefaultReprEqOrigin'
-- constructor from within a 'CtOrigin'.
defaultReprEqOrigins :: CtOrigin -> [(CtOrigin, (TcType, TcType))]
-defaultReprEqOrigins = go
+defaultReprEqOrigins = foldMapCtOrigin go
where
go = \case
- DefaultReprEqOrigin l r o -> (o, (l, r)) : go o
-
- -- Handle recursive occurrences of 'CtOrigin' within 'CtOrigin'.
- -- TODO: use syb to derive this, so that the following never goes out of date.
- ScOrigin cls_or_qc _ ->
- case cls_or_qc of
- IsClsInst -> []
- IsQC _ o -> go o
- KindEqOrigin _ _ o _ -> go o
- CycleBreakerOrigin o -> go o
- WantedSuperclassOrigin _ o -> go o
-
+ DefaultReprEqOrigin l r o -> [(o, (l, r))]
_ -> []
{- *********************************************************************
@@ -1046,6 +1129,37 @@ isPushCallStackOrigin_maybe orig = Just orig_fs
where
orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig))
+{- *********************************************************************
+* *
+ HasField and CtOrigin
+* *
+********************************************************************* -}
+
+-- | Does this constraint arise from GHC internal mechanisms that desugar to
+-- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)?
+--
+-- Used in two places:
+--
+-- - When reporting an unsolved 'HasField' constraint, to decide whether to
+-- print an informative message to the user.
+-- See (H2e) in Note [Error messages for unsolved HasField constraints]
+-- in GHC.Tc.Errors.
+-- - To avoid emitting a poor "incomplete record selector" warning directly
+-- in typechecker, in cases when the desugarer will be able to emit a better
+-- error message, due to having better pattern match checking information.
+-- See (IRS7) in Note [Detecting incomplete record selectors]
+-- in GHC.HsToCore.Pmc
+isHasFieldOrigin :: CtOrigin -> Bool
+isHasFieldOrigin = Semi.getAny . foldMapCtOrigin (Semi.Any . go)
+ where
+ go = \case
+ OccurrenceOf n -> n == getFieldName
+ OccurrenceOfRecSel {} -> True
+ RecordFieldProjectionOrigin {} -> True
+ GetFieldOrigin {} -> True
+ RecordUpdOrigin {} -> True
+ _ -> False
+
{-
************************************************************************
* *
=====================================
testsuite/tests/overloadedrecflds/should_compile/T26686.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE GADTs #-}
+
+{-# OPTIONS_GHC -Wincomplete-record-selectors #-}
+
+module T26686 where
+
+import Data.Kind
+
+data A
+data B
+
+data G = G { f2 :: Int }
+
+data T x where
+ TA :: { ta :: G } -> T x
+ TB :: { tb :: G } -> T B
+
+data H a = H { f1 :: T a }
+
+test1_ok :: T A -> G
+test1_ok = (.ta)
+test2_ok :: T A -> Int
+test2_ok = (.ta.f2)
+test3_ok :: H A -> G
+test3_ok = (.f1.ta)
+test4_ok :: H A -> Int
+test4_ok = (.f1.ta.f2)
+
+test1_bad :: T x -> G
+test1_bad = (.ta)
+test2_bad :: T x -> Int
+test2_bad = (.ta.f2)
+test3_bad :: H x -> G
+test3_bad = (.f1.ta)
+test4_bad :: H x -> Int
+test4_bad = (.f1.ta.f2)
=====================================
testsuite/tests/overloadedrecflds/should_compile/T26686.stderr
=====================================
@@ -0,0 +1,16 @@
+T26686.hs:31:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
+ Selecting the record field ‘ta’ may fail for the following constructors:
+ TB
+
+T26686.hs:33:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
+ Selecting the record field ‘ta’ may fail for the following constructors:
+ TB
+
+T26686.hs:35:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
+ Selecting the record field ‘ta’ may fail for the following constructors:
+ TB
+
+T26686.hs:37:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
+ Selecting the record field ‘ta’ may fail for the following constructors:
+ TB
+
=====================================
testsuite/tests/overloadedrecflds/should_compile/all.T
=====================================
@@ -30,6 +30,7 @@ test('T21720', req_th, compile, [''])
test('T21898', normal, compile, [''])
test('T22160', [extra_files(['T22160_A.hs', 'T22160_B.hs', 'T22160_C.hs'])]
, multimod_compile, ['T22160_A T22160_B T22160_C T22160', '-v0'])
+test('T26686', normal, compile, [''])
test('DupFldFixity3', normal, compile, [''])
test('overloadedrecflds10'
, [extra_files(['OverloadedRecFlds10_A.hs', 'OverloadedRecFlds10_B.hs', 'OverloadedRecFlds10_C.hs'])]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c3e6ba9f03d19a4fa85aee6a4c417…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c3e6ba9f03d19a4fa85aee6a4c417…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] ghci: Mention active language edition in startup banner
by Marge Bot (＠marge-bot) 20 Mar '26
by Marge Bot (＠marge-bot) 20 Mar '26
20 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e34cb6da by Adam Gundry at 2026-03-20T12:20:00-04:00
ghci: Mention active language edition in startup banner
Per GHC proposal 632, this makes the GHCi startup banner include
the active language edition, plus an indication of whether this
was the default (as opposed to being explicitly selected via an
option such as `-XGHC2024`). For example:
```
$ ghci
GHCi, version 9.14.1: https://www.haskell.org/ghc/ :? for help
Using default language edition: GHC2024
ghci>
```
Fixes #26037.
- - - - -
2 changed files:
- ghc/GHCi/UI.hs
- ghc/Main.hs
Changes:
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -23,7 +23,8 @@ module GHCi.UI (
GhciSettings(..),
defaultGhciSettings,
ghciCommands,
- ghciWelcomeMsg
+ ghciWelcomeMsg,
+ languageEditionMsg
) where
-- GHCi
@@ -199,6 +200,10 @@ versionString = "GHCi, version " ++ cProjectVersion
ghciWelcomeMsg :: String
ghciWelcomeMsg = versionString ++ ": https://www.haskell.org/ghc/ :? for help"
+languageEditionMsg :: Maybe Language -> String
+languageEditionMsg Nothing = "Using default language edition: " ++ show defaultLanguage
+languageEditionMsg (Just lang) = "Using language edition: " ++ show lang
+
ghciCommands :: [Command]
ghciCommands = map mkCmd [
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
=====================================
ghc/Main.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Platform
import GHC.Platform.Host
#if defined(HAVE_INTERNAL_INTERPRETER)
-import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
+import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings, languageEditionMsg )
#endif
import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins )
@@ -334,7 +334,9 @@ showBanner _postLoadMode dflags = do
#if defined(HAVE_INTERNAL_INTERPRETER)
-- Show the GHCi banner
- when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
+ when (isInteractiveMode _postLoadMode && verb >= 1) $
+ do putStrLn ghciWelcomeMsg
+ putStrLn $ languageEditionMsg (language dflags)
#endif
-- Display details of the configuration in verbose mode
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e34cb6da7b980e2ccba320c38006abc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e34cb6da7b980e2ccba320c38006abc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base] Lots of wibbles
by Simon Peyton Jones (＠simonpj) 20 Mar '26
by Simon Peyton Jones (＠simonpj) 20 Mar '26
20 Mar '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC
Commits:
f8a69d19 by Simon Peyton Jones at 2026-03-20T15:23:42+00:00
Lots of wibbles
..including help from Matthew, to module graph dependencies
- - - - -
66 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Gen/Default.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/DefaultEnv.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- libraries/base/src/Control/Applicative.hs
- libraries/base/src/Data/Bifoldable1.hs
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/Enum.hs
- libraries/base/src/Data/Foldable1.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/KnownKeyNames.hs
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/base/src/GHC/Stats.hs
- libraries/base/src/GHC/Weak/Finalize.hs
- libraries/base/src/System/Exit.hs
- libraries/base/src/System/IO/OS.hs
- libraries/base/src/System/IO/Unsafe.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Classes.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/String.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs
- libraries/ghc-internal/src/GHC/Internal/Enum.hs
- libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Num.hs
- libraries/ghc-internal/src/GHC/Internal/Num.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Real.hs
- libraries/ghc-internal/src/GHC/Internal/Real.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Show.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-prim/ghc-prim.cabal
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
- testsuite/tests/parser/should_fail/T16270h.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8a69d19f61a61831bb74a91e88b9c1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8a69d19f61a61831bb74a91e88b9c1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0