- ghc-commits - Haskell.org

[Git][ghc/ghc][master] 2 commits: hadrian: don't compile RTS with -Winline
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b883f08f by Cheng Shao at 2026-03-20T12:31:33-04:00 hadrian: don't compile RTS with -Winline This patch removes `-Winline` from cflags when compiling the RTS, given that: 1. It generates a huge pile of spam and hurts developer experience 2. Whether inlining happens is highly dependent on toolchains, flavours, etc, and it's not really an issue to fix if inlining doesn't happen; it's a hint to the C compiler anyway. Fixes #27060. - - - - - 333387d6 by Cheng Shao at 2026-03-20T12:31:33-04:00 hadrian: compile libffi-clib with -Wno-deprecated-declarations This patch adds `-Wno-deprecated-declarations` to cflags of `libffi-clib`, given that it produces noise at compile-time that aren't really our issue to fix anyway, it's from vendored libffi source code. - - - - - 1 changed file: - hadrian/src/Settings/Packages.hs Changes: ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -280,6 +280,8 @@ ghcInternalArgs = package ghcInternal ? do libffiPackageArgs :: Args libffiPackageArgs = package libffi ? do rtsWays <- getRtsWays + -- noise when compiling libffi sources + let cArgs = mconcat [ arg "-Wno-deprecated-declarations" ] mconcat [ builder (Cabal Flags) ? mconcat [ any (wayUnit Profiling) rtsWays `cabalFlag` "profiling" @@ -287,6 +289,8 @@ libffiPackageArgs = package libffi ? do , any (wayUnit Dynamic) rtsWays `cabalFlag` "dynamic" , any (wayUnit Threaded) rtsWays `cabalFlag` "threaded" ] + , builder (Cc (FindCDependencies CDep)) ? cArgs + , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs ] -- | RTS-specific command line arguments. @@ -377,9 +381,6 @@ rtsPackageArgs = package rts ? do , inputs ["**/Jumps_V32.c"] ? pure [ "-mavx2" | x86 ] , inputs ["**/Jumps_V64.c"] ? pure [ "-mavx512f" | x86 ] - -- inlining warnings happen in Compact - , inputs ["**/Compact.c"] ? arg "-Wno-inline" - -- emits warnings about call-clobbered registers on x86_64 , inputs [ "**/StgCRun.c" , "**/win32/ConsoleHandler.c", "**/win32/ThrIOManager.c"] ? arg "-w" @@ -446,7 +447,6 @@ rtsWarnings = mconcat , arg "-Wstrict-prototypes" , arg "-Wmissing-prototypes" , arg "-Wmissing-declarations" - , arg "-Winline" , arg "-Wpointer-arith" , arg "-Wmissing-noreturn" , arg "-Wnested-externs" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b1be555be4f0989d78c274991c504… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b1be555be4f0989d78c274991c504… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] JS: install rts/Types.h header file (#27033)
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5b1be555 by Sylvain Henry at 2026-03-20T12:30:48-04:00 JS: install rts/Types.h header file (#27033) It was an omission, making HsFFI.h not usable with GHC using the JS backend. - - - - - 6 changed files: - rts/rts.cabal - + testsuite/tests/javascript/js-c-sources/T27033.hs - + testsuite/tests/javascript/js-c-sources/T27033.stdout - + testsuite/tests/javascript/js-c-sources/T27033_c.c - + testsuite/tests/javascript/js-c-sources/T27033_js.js - testsuite/tests/javascript/js-c-sources/all.T Changes: ===================================== rts/rts.cabal ===================================== @@ -150,6 +150,7 @@ library install-includes: HsFFI.h MachDeps.h Rts.h RtsAPI.h Stg.h ghcautoconf.h ghcconfig.h ghcplatform.h ghcversion.h DerivedConstants.h + rts/Types.h stg/MachRegs.h stg/MachRegs/arm32.h stg/MachRegs/arm64.h ===================================== testsuite/tests/javascript/js-c-sources/T27033.hs ===================================== @@ -0,0 +1,4 @@ +main :: IO () +main = print =<< increment 41 + +foreign import javascript "increment_wrapper" increment :: Int -> IO Int ===================================== testsuite/tests/javascript/js-c-sources/T27033.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/javascript/js-c-sources/T27033_c.c ===================================== @@ -0,0 +1,5 @@ +#include "HsFFI.h" + +HsInt increment(HsInt x) { + return x + 1; +} ===================================== testsuite/tests/javascript/js-c-sources/T27033_js.js ===================================== @@ -0,0 +1,5 @@ +//#OPTIONS:EMCC:EXPORTED_FUNCTIONS=_increment + +function increment_wrapper(x) { + return _increment(x); +} ===================================== testsuite/tests/javascript/js-c-sources/all.T ===================================== @@ -3,3 +3,4 @@ setTestOpts(when(not(js_arch()),skip)) test('js-c-sources01', extra_files(['js-c-sources01_c.c','js-c-sources01_js.js']), compile_and_run, ['js-c-sources01_c.c js-c-sources01_js.js']) test('js-c-sources02', extra_files(['js-c-sources02_c.c','js-c-sources02_js.js']), compile_and_run, ['js-c-sources02_c.c js-c-sources02_js.js']) +test('T27033', extra_files(['T27033_c.c','T27033_js.js']), compile_and_run, ['T27033_c.c T27033_js.js']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b1be555be4f0989d78c274991c5046… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b1be555be4f0989d78c274991c5046… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: fix ghc-in-ghci flavour stage0 shared libraries
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2c57de29 by Cheng Shao at 2026-03-20T12:29:55-04:00 hadrian: fix ghc-in-ghci flavour stage0 shared libraries This patch fixes missing stage0 shared libraries in hadrian ghc-in-ghci flavour, which was accidentally dropped in 669d09f950a6e88b903d9fd8a7571531774d4d5d and resulted in a regression in HLS support on linux/macos. Fixes #27057. - - - - - 1 changed file: - hadrian/src/Settings/Flavours/GhcInGhci.hs Changes: ===================================== hadrian/src/Settings/Flavours/GhcInGhci.hs ===================================== @@ -1,14 +1,22 @@ module Settings.Flavours.GhcInGhci (ghcInGhciFlavour) where +import qualified Data.Set as Set import Expression import Flavour +import Oracles.Flag import {-# SOURCE #-} Settings.Default -- Please update doc/flavours.md when changing this file. ghcInGhciFlavour :: Flavour ghcInGhciFlavour = disableProfiledLibs $ defaultFlavour { name = "ghc-in-ghci" - , extraArgs = ghciArgs + , extraArgs = ghciArgs + , libraryWays = + Set.fromList + <$> mconcat + [ pure [vanilla] + , platformSupportsSharedLibs ? pure [dynamic] + ] } ghciArgs :: Args View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c57de2947b17c2b4ff11659aa73749… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c57de2947b17c2b4ff11659aa73749… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Use OsPath rather than FilePath in Downsweep cache
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3e767f98 by Matthew Pickering at 2026-03-20T12:29:11-04:00 Use OsPath rather than FilePath in Downsweep cache This gets us one step closure to uniformly using `OsPath` in the compiler. - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -56,7 +56,7 @@ import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.Maybe as M -import GHC.Data.OsPath ( unsafeEncodeUtf ) +import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf ) import GHC.Data.StringBuffer import GHC.Data.Graph.Directed.Reachability import qualified GHC.LanguageExtensions as LangExt @@ -216,9 +216,9 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map :: M.Map (UnitId, OsPath) ModSummary old_summary_map = - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries] -- Dependencies arising on a unit (backpack and module linking deps) unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] @@ -384,7 +384,7 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- This function will start at the given roots, and traverse downwards to find -- all the dependencies, all the way to the leaf units. downsweepFromRootNodes :: HscEnv - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -> [ModuleName] -> Bool -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies @@ -442,7 +442,7 @@ type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { downsweep_hsc_env :: HscEnv , _downsweep_mode :: DownsweepMode - , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary + , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary , _downsweep_excl_mods :: [ModuleName] } @@ -715,7 +715,7 @@ linkNodes summaries uid hue = getRootSummary :: [ModuleName] -> - M.Map (UnitId, FilePath) ModSummary -> + M.Map (UnitId, OsPath) ModSummary -> HscEnv -> Target -> IO (Either DriverMessages ModSummary) @@ -1183,7 +1183,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> M.Map (UnitId, OsPath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -1192,7 +1192,7 @@ summariseFile summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries = do let location = ms_location $ old_summary @@ -1213,6 +1213,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + src_fn_os = unsafeEncodeUtf src_fn -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -1302,7 +1303,7 @@ data SummariseResult = -- --make mode. summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -> IsBootInterface -> Located ModuleName -> PkgQual @@ -1382,7 +1383,7 @@ summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg exc -- for it and potentially compile it. summariseModuleWithSource :: HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Maybe (StringBuffer, UTCTime) @@ -1411,7 +1412,7 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo where dflags = hsc_dflags hsc_env new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the @@ -1422,6 +1423,8 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo Nothing -> checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h | otherwise = new_summary loc mod src_fn h + where + src_fn_os = unsafeEncodeUtf src_fn new_summary :: ModLocation -> Module View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e767f9889483ad7b764e12baa0155c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e767f9889483ad7b764e12baa0155c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Core: add constant-folding rules for Addr# eq/ne (#18032)
by Marge Bot (＠marge-bot) 21 Mar '26

21 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ae4ddd60 by Sylvain Henry at 2026-03-20T12:28:28-04:00 Core: add constant-folding rules for Addr# eq/ne (#18032) - - - - - 4 changed files: - compiler/GHC/Core/Opt/ConstantFold.hs - + testsuite/tests/simplCore/should_compile/T18032.hs - + testsuite/tests/simplCore/should_compile/T18032.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -844,6 +844,14 @@ primOpRules nm = \case -- Misc + -- See Note [Constant folding for Addr# equality] + AddrEqOp -> mkPrimOpRule nm 2 [ equalArgs >> (trueValInt <$> getPlatform) + , match_litAddr_eq True + ] + AddrNeOp -> mkPrimOpRule nm 2 [ equalArgs >> (falseValInt <$> getPlatform) + , match_litAddr_eq False + ] + AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] @@ -969,6 +977,39 @@ cmpOp cmp env = go -------------------------- +-- Note [Constant folding for Addr# equality] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We constant-fold (eqAddr# "foo"# "bar"#) when both arguments are string +-- literals with *different* byte content. Because the bytes differ, the two +-- literals cannot reside at the same address, so the result is definitely +-- False (or True for neAddr#). +-- +-- We use exprIsLiteral_maybe (via isLiteral) rather than binaryLit/cmpOp, +-- because string literals are frequently floated out to the top level as CAF +-- bindings. That turns them into variables, and we must look through those +-- variable unfoldings to recover the underlying LitString. +-- +-- When both literals have the *same* byte content we do NOT fold to True. +-- Two distinct literal occurrences in the source may end up at different +-- addresses in the object file (the linker is not required to merge them), +-- so pointer equality is not guaranteed by equal content alone. The +-- equalArgs already handles the case where both arguments are the *same* +-- expression (provably the same pointer). + +match_litAddr_eq :: Bool -- ^ True <=> eqAddr# (fold different-content to False) + -- False <=> neAddr# (fold different-content to True) + -> RuleM CoreExpr +-- See Note [Constant folding for Addr# equality] +match_litAddr_eq is_eq = do + platform <- getPlatform + [e1, e2] <- getArgs + LitString s1 <- isLiteral e1 + LitString s2 <- isLiteral e2 + guard (s1 /= s2) + return $ if is_eq then falseValInt platform else trueValInt platform + +-------------------------- + negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate negOp env lit = case lit of (LitFloating prec f) -> Just $ Lit $ LitFloating prec $ ===================================== testsuite/tests/simplCore/should_compile/T18032.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE MagicHash #-} +module T18032 where + +import GHC.Exts + +-- Different byte content: eqAddr# must be False (0), neAddr# must be True (1) +a = I# (eqAddr# "foo"# "bar"#) +b = I# (neAddr# "foo"# "bar"#) + +-- Same variable on both sides: eqAddr# must be True (1), neAddr# must be False (0) +c = let s = "baz"# in I# (eqAddr# s s) +d = let s = "baz"# in I# (neAddr# s s) ===================================== testsuite/tests/simplCore/should_compile/T18032.stderr ===================================== @@ -0,0 +1,15 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 10, types: 4, coercions: 0, joins: 0/0} + +a = I# 0# + +b = I# 1# + +c = b + +d = a + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -593,3 +593,4 @@ test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds']) test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques']) test('T26826', normal, compile, ['-O']) test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all']) +test('T18032', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae4ddd60d2a16c7463175196c319832… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae4ddd60d2a16c7463175196c319832… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] JS: replace BigInt with Number arithmetic for 32/64-bit quot/rem (#23597)
by Marge Bot (＠marge-bot) 21 Mar '26

21 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) 21 Mar '26

21 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) 21 Mar '26

21 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) 21 Mar '26

21 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) 21 Mar '26

21 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