Cheng Shao pushed to branch wip/shrink-block-free at Glasgow Haskell Compiler / GHC
Commits:
1c1e01c1 by Cheng Shao at 2025-12-22T18:33:38+01:00
rts: opportunistically reclaim slop space in shrinkMutableByteArray#
Previously, `shrinkMutableByteArray#` shrinks a `MutableByteArray#`
in-place by assigning the new size to it, and zeroing the extra slop
space. That slop space is not reclaimed and wasted. But it's often the
case that we allocate a `MutableByteArray#` upfront, then shrink it
shortly after, so the `MutableByteArray#` closure sits right at the
end of a nursery block; this patch identifies such chances, and also
shrink `bd->free` if possible, reducing heap space fragmentation.
Co-authored-by: Codex
-------------------------
Metric Decrease:
T10678
-------------------------
- - - - -
2 changed files:
- rts/PrimOps.cmm
- utils/deriveConstants/Main.hs
Changes:
=====================================
rts/PrimOps.cmm
=====================================
@@ -204,12 +204,47 @@ stg_isMutableByteArrayWeaklyPinnedzh ( gcptr mba )
stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> State# s
{
- ASSERT(new_size <= StgArrBytes_bytes(mba));
+ W_ old_size, old_wds, new_wds;
+ W_ bd;
+
+ old_size = StgArrBytes_bytes(mba);
+ ASSERT(new_size <= old_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.
+ bd = Bdescr(mba);
+ if (bdescr_free(bd) != mba + WDS(old_wds) ||
+ (bd != StgRegTable_rCurrentAlloc(BaseReg) && bd != Capability_pinned_object_block(MyCapability()))) {
+ OVERWRITING_CLOSURE_MUTABLE(mba, new_wds);
+ StgArrBytes_bytes(mba) = new_size;
+ // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays]
+ return ();
+ }
- OVERWRITING_CLOSURE_MUTABLE(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
- ROUNDUP_BYTES_TO_WDS(new_size)));
+ // Check passes, we can shrink bd->free! Also uninitialize the slop
+ // if zero_on_gc is enabled, to conform with debug RTS convention.
StgArrBytes_bytes(mba) = new_size;
- // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays]
+ IF_DEBUG(zero_on_gc,
+ prim %memset(mba + WDS(new_wds),
+ 0xaa,
+ WDS(old_wds - new_wds),
+ 1);
+ );
+ bdescr_free(bd) = mba + WDS(new_wds);
return ();
}
@@ -223,18 +258,10 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)
{
- W_ new_size_wds;
-
- ASSERT(new_size >= 0);
-
- new_size_wds = ROUNDUP_BYTES_TO_WDS(new_size);
-
- if (new_size_wds <= BYTE_ARR_WDS(mba)) {
- OVERWRITING_CLOSURE_MUTABLE(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
- new_size_wds));
- StgArrBytes_bytes(mba) = new_size;
- // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays]
+ ASSERT(new_size `ge` 0);
+ if (new_size <= StgArrBytes_bytes(mba)) {
+ call stg_shrinkMutableByteArrayzh(mba, new_size);
return (mba);
} else {
(P_ new_mba) = call stg_newByteArrayzh(new_size);
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -395,6 +395,7 @@ wanteds os = concat
,fieldOffset Both "StgRegTable" "rCurrentTSO"
,fieldOffset Both "StgRegTable" "rCurrentNursery"
,fieldOffset Both "StgRegTable" "rHpAlloc"
+ ,structField C "StgRegTable" "rCurrentAlloc"
,structField C "StgRegTable" "rRet"
,structField C "StgRegTable" "rNursery"
@@ -414,6 +415,7 @@ wanteds os = concat
,structField C "Capability" "weak_ptr_list_hd"
,structField C "Capability" "weak_ptr_list_tl"
,structField C "Capability" "n_run_queue"
+ ,structField C "Capability" "pinned_object_block"
,structField Both "bdescr" "start"
,structField Both "bdescr" "free"
@@ -629,6 +631,8 @@ wanteds os = concat
"RTS_FLAGS" "DebugFlags.sanity"
,structField_ C "RtsFlags_DebugFlags_weak"
"RTS_FLAGS" "DebugFlags.weak"
+ ,structField_ C "RtsFlags_DebugFlags_zero_on_gc"
+ "RTS_FLAGS" "DebugFlags.zero_on_gc"
,structField_ C "RtsFlags_GcFlags_initialStkSize"
"RTS_FLAGS" "GcFlags.initialStkSize"
,structField_ C "RtsFlags_MiscFlags_tickInterval"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c1e01c19beba39dfcaea49a8c55c782...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c1e01c19beba39dfcaea49a8c55c782...
You're receiving this email because of your account on gitlab.haskell.org.
