feat: add region-based heap collection foundation

cl-cc-runtime.asd

@@ -62,6 +62,7 @@ structured logging, process execution and JSON rather than reimplementing them."
    (:file "heap-core")
    (:file "heap-sanitizer")
    (:file "heap-layout")
+   (:file "heap-region")
    (:file "heap-access")
    (:file "heap-forwarding")
    (:file "heap-numa")
@@ -92,6 +93,7 @@ structured logging, process execution and JSON rather than reimplementing them."
    (:file "gc-major-sweep")
    (:file "gc-compact")
    (:file "gc-concurrent-sweep")
+   (:file "gc-region-collect")
    (:file "gc-major-collect")
    (:file "gc-sweep-telemetry")
    ;; Synchronization & concurrency primitives
@@ -234,7 +236,8 @@ structured logging, process execution and JSON rather than reimplementing them."
    (:file "async-test")
    (:file "portable-test")
    (:file "gc-workers-test")
-   (:file "gc-major-sweep-incremental-test"))
+   (:file "gc-major-sweep-incremental-test")
+   (:file "gc-region-collect-test"))
   ;; Not HOST-KIT:SYMBOL-CALL: a .asd is read before :depends-on is ever
   ;; consulted, so a CL-HOST-KIT-prefixed token here would be a read-time
   ;; PACKAGE-DOES-NOT-EXIST error regardless of what the system depends on.

src/gc-major-collect.lisp

@@ -56,6 +56,9 @@
           (unless ok
             (error "FR-339: tri-color invariant violated at old object ~D"
                    violating-addr)))
+        (when (and (boundp '*rt-region-mixed-collection-enabled-p*)
+                   *rt-region-mixed-collection-enabled-p*)
+          (rt-gc-region-mixed-collect heap))
         ;; Phase 4: sweep old space.  Concurrent mode uses the same sweep worker
         ;; entry point as the background/lazy path; the portable Pure CL runtime
         ;; joins before returning so the public heap invariants remain unchanged.

src/gc-region-collect.lisp

@@ -0,0 +1,68 @@
+;;;; gc-region-collect.lisp -- mixed-collection selection and evacuation failure.
+(in-package :cl-cc/runtime)
+
+(defun %rt-gc-region-refresh (heap region)
+  "Recompute REGION occupancy from mark bits after major marking."
+  (let ((addr (rt-heap-region-start-word region))
+        (limit (min (rt-heap-region-end-word region) (rt-heap-old-free heap)))
+        (allocated 0)
+        (live 0))
+    (loop while (< addr limit) do
+      (let ((header (rt-heap-object-header heap addr)))
+        (if (and (integerp header) (plusp (rt-header-size header)))
+            (let ((size (rt-header-size header)))
+              (incf allocated (* size 8))
+              (when (header-marked-p header)
+                (incf live (* size 8)))
+              (incf addr size))
+            (setf addr limit))))
+    (setf (rt-heap-region-allocated-bytes region) allocated
+          (rt-heap-region-live-bytes region) live
+          (rt-heap-region-garbage-ratio region)
+          (if (zerop allocated)
+              1.0d0
+              (/ (float (- allocated live) 1.0d0) allocated)))))
+
+(defun rt-gc-region-select-mixed (heap &key (max-regions 1)
+                                               (min-garbage-ratio 0.1d0))
+  "Refresh and select the highest-garbage old-space regions for mixed GC."
+  (let ((candidates nil))
+    (map nil (lambda (region)
+               (%rt-gc-region-refresh heap region)
+               (setf (rt-heap-region-selected-p region) nil)
+               (when (and (plusp (rt-heap-region-allocated-bytes region))
+                          (>= (rt-heap-region-garbage-ratio region)
+                              min-garbage-ratio))
+                 (push region candidates)))
+         (rt-heap-regions heap))
+    (loop for region in (subseq (sort candidates #'>
+                                         :key #'rt-heap-region-garbage-ratio)
+                                0 (min max-regions (length candidates)))
+          do (setf (rt-heap-region-selected-p region) t))
+    (remove-if-not #'rt-heap-region-selected-p candidates)))
+
+(defun rt-gc-region-handle-evacuation-failure (region reason)
+  "Record that REGION stayed in place because evacuation could not complete."
+  (setf (rt-heap-region-evacuation-failed-p region) t)
+  (list :status :failed :region region :reason reason))
+
+(defun rt-gc-region-mixed-collect (heap &key (max-regions 1)
+                                              (min-garbage-ratio 0.1d0)
+                                              evacuate-fn)
+  "Select mixed-collection candidates and attempt their evacuation.
+
+EVACUATE-FN receives HEAP and REGION. A missing function is an explicit
+evacuation failure, leaving the region for the normal mark-sweep fallback."
+  (let ((results nil))
+    (dolist (region (rt-gc-region-select-mixed
+                     heap :max-regions max-regions
+                     :min-garbage-ratio min-garbage-ratio))
+      (push (if evacuate-fn
+                (handler-case
+                    (funcall evacuate-fn heap region)
+                  (error (condition)
+                    (rt-gc-region-handle-evacuation-failure region condition)))
+                (rt-gc-region-handle-evacuation-failure
+                 region :no-evacuation-target))
+            results))
+    (nreverse results)))

src/heap-access.lisp

@@ -65,7 +65,7 @@
              managed-words +compressed-heap-region-words+))
     (when *compressed-pointers-enabled*
       (setf *heap-base-address* young-from-base))
-    (%make-rt-heap
+    (let ((heap (%make-rt-heap
      :words                          words
      :young-from-base                young-from-base
      :young-to-base                  young-to-base
@@ -120,9 +120,13 @@
      :numa-node-map                  numa-node-map
      :numa-gc-schedule               nil
      :interleaved-regions            nil
+     :regions                        (make-array 0)
+     :region-size-words              +rt-heap-region-size-words+
      :co-location-hints              co-location-hints
      :gc-inhibit                     nil
      :gc-pending                     nil)))
+      (rt-heap-initialize-regions heap)
+      heap)))
 
 (defun rt-heap-ref (heap index)
   "Read word at absolute INDEX from HEAP.

src/heap-core.lisp

@@ -64,6 +64,8 @@
   (numa-node-map nil :type hash-table)
   (numa-gc-schedule nil :type list)
   (interleaved-regions nil :type list)
+  (regions nil :type simple-vector)
+  (region-size-words 0 :type fixnum)
   (co-location-hints nil :type hash-table)
   (gc-inhibit      nil  :type boolean)
   (gc-pending      nil  :type boolean))

src/heap-region.lisp

@@ -0,0 +1,45 @@
+;;;; heap-region.lisp -- fixed-size old-space region metadata for mixed GC.
+(in-package :cl-cc/runtime)
+
+(defconstant +rt-heap-region-size-words+ (floor (* 1024 1024) 8)
+  "Default region size in heap words (one megabyte at eight bytes per word).")
+
+(defstruct (rt-heap-region (:constructor %make-rt-heap-region)
+                           (:conc-name rt-heap-region-))
+  "Metadata for one contiguous portion of the managed old generation."
+  (index 0 :type fixnum)
+  (start-word 0 :type fixnum)
+  (end-word 0 :type fixnum)
+  (generation :old :type keyword)
+  (allocated-bytes 0 :type fixnum)
+  (live-bytes 0 :type fixnum)
+  (garbage-ratio 0.0d0 :type double-float)
+  (remembered-set (make-hash-table :test #'eql))
+  (selected-p nil :type boolean)
+  (evacuation-failed-p nil :type boolean))
+
+(defparameter *rt-region-mixed-collection-enabled-p* nil
+  "When true, major collection performs the region selection pass before sweep.")
+
+(defun rt-heap-initialize-regions (heap)
+  "Create the old-space region array for HEAP and return HEAP."
+  (let* ((size (max 1 (rt-heap-region-size-words heap)))
+         (old-size (rt-heap-old-size heap))
+         (count (ceiling old-size size))
+         (regions (make-array count)))
+    (dotimes (index count)
+      (let* ((start (+ (rt-heap-old-base heap) (* index size)))
+             (end (min (+ start size) (+ (rt-heap-old-base heap) old-size))))
+        (setf (aref regions index)
+              (%make-rt-heap-region :index index :start-word start :end-word end))))
+    (setf (rt-heap-regions heap) regions)
+    heap))
+
+(defun rt-heap-region-for-address (heap address)
+  "Return the old-space region containing ADDRESS, or NIL."
+  (let ((base (rt-heap-old-base heap))
+        (size (rt-heap-region-size-words heap))
+        (regions (rt-heap-regions heap)))
+    (when (and (plusp size) regions (>= address base)
+               (< address (+ base (rt-heap-old-size heap))))
+      (aref regions (floor (- address base) size)))))

src/package.lisp

@@ -634,6 +634,11 @@
     #:satb-write-barrier #:satb-drain-queue #:*satb-queue*
     #:+gc-region-size+ #:gc-region #:make-gc-region #:*gc-regions*
     #:*gc-pause-target-ms* #:estimate-region-garbage-ratio
+    #:rt-heap-region #:rt-heap-regions #:rt-heap-region-size-words
+    #:rt-heap-region-for-address #:rt-heap-initialize-regions
+    #:*rt-region-mixed-collection-enabled-p*
+    #:rt-gc-region-select-mixed #:rt-gc-region-mixed-collect
+    #:rt-gc-region-handle-evacuation-failure
     ;; ── Compressed pointers / SSO strings (value.lisp) ──
     #:+compressed-pointer-flag+ #:+compressed-pointer-offset-mask+
     #:+compressed-heap-region-bytes+ #:+compressed-heap-region-words+

t/gc-region-collect-test.lisp

@@ -0,0 +1,24 @@
+;;;; t/gc-region-collect-test.lisp -- mixed region selection and fallback.
+(in-package :cl-cc-runtime/test)
+
+(describe "region mixed collection"
+  (it "creates an old-space region array and resolves old addresses"
+    (let ((heap (cl-cc/runtime::make-rt-heap :young-size 32 :old-size 16)))
+      (expect (length (cl-cc/runtime::rt-heap-regions heap)) :to-be 1)
+      (expect (cl-cc/runtime::rt-heap-region-for-address
+               heap (cl-cc/runtime::rt-heap-old-base heap)) :to-be-truthy)))
+  (it "selects a region and records evacuation failure for the fallback path"
+    (let ((heap (cl-cc/runtime::make-rt-heap :young-size 32 :old-size 16)))
+      (let ((addr (cl-cc/runtime::rt-gc-alloc heap :old 2)))
+        (cl-cc/runtime::rt-heap-set-header
+         heap addr (cl-cc/runtime::make-rt-header 2 1 :gc-bits 0))
+        (let ((region (aref (cl-cc/runtime::rt-heap-regions heap) 0)))
+          (cl-cc/runtime::rt-heap-set-header
+           heap addr (cl-cc/runtime::header-set-mark
+                      (cl-cc/runtime::rt-heap-object-header heap addr)))
+          (let ((result (cl-cc/runtime::rt-gc-region-mixed-collect
+                         heap :max-regions 1 :min-garbage-ratio 0.0d0)))
+            (expect (length result) :to-be 1)
+            (expect (getf (first result) :status) :to-be :failed)
+            (expect (cl-cc/runtime::rt-heap-region-evacuation-failed-p region)
+                    :to-be-truthy)))))))