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.