Menu
▾
▴
[Sbcl-commits] master: code/room: Completely rewrite MAP-ALLOCATED-OBJECTS.
|
From: Alastair B. <lis...@us...> - 2013-05-11 14:00:40
|
The branch "master" has been updated in SBCL:
via 24ecee137a93b3f769d1aa04589a5c9b0e76ea66 (commit)
from 4c86741fbb42b15472c3e4b615935159566427d9 (commit)
- Log -----------------------------------------------------------------
commit 24ecee137a93b3f769d1aa04589a5c9b0e76ea66
Author: Alastair Bridgewater <ny...@ka...>
Date: Mon Apr 29 22:56:14 2013 -0400
code/room: Completely rewrite MAP-ALLOCATED-OBJECTS.
* The old version of M-A-O consisted of bizaare toplevel logic,
a scheme for figuring out what each heap object was and its size
that did not parallel what the garbage collector used and may or
may not have been correct, and relied heavily on inlining to
reduce consing.
* This new version of M-A-O uses straightforward toplevel logic,
a scheme for figuring out what each heap object is and its size
that directly parallels what the garbage collector uses and is
verifiably correct, and relies heavily on the aligned unboxed
pointer to fixnum equivalence to reduce consing.
* The new interface to M-A-O no longer includes the optional
"careful" argument, as it gains us nothing once the underlying
mechanism is so obviously correct. sb-introspect has been updated
appropriately.
* The way the new implementation walks the heap and page table
requires direct access to a "static" global variable in gencgc.c,
so the "static" attribute has been removed.
* This implementation has been lightly tested on an x86-64 and
PPC, and it seems to work quite well, but there are still some
fairly obvious non-optimalities in terms of generated code (as
seen in the trace-file output from the cross compiler). It does
pass the two test cases that exhausted the heap on PPC with the
previous implementation.
---
NEWS | 8 +
contrib/sb-introspect/introspect.lisp | 3 +-
src/code/room.lisp | 449 +++++++++++++++++++--------------
src/runtime/gencgc.c | 2 +-
4 files changed, 270 insertions(+), 192 deletions(-)
diff --git a/NEWS b/NEWS
index 8fb5691..de7a9c9 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,8 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.1.7:
+ * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of
+ ROOM, plus a few SB-INTROSPECT functions) has been completely
+ rewritten, it may now exhibit different bugs than before.
* enhancement: RUN-PROGRAM supports a :DIRECTORY argument to set
the working directory of the spawned process.
(lp#791800) (patch by Matthias Benkard)
@@ -12,6 +15,9 @@ changes relative to sbcl-1.1.7:
defoptimizer types ir2convert and stack-allocate-result.
* enhancement: better type derivation for APPEND, NCONC, LIST.
(lp#538957)
+ * enhancement: MAP-ALLOCATED-OBJECTS (the heart of ROOM) now walks the
+ heap in a manner similar to the GC rather than its previous ad-hoc
+ scheme, and is therefore no less and possibly more accurate.
* bug fix: type derivation for LOG{AND,IOR,XOR} scales linearly instead
of quadratically with the size of the input in the worst case.
(lp#1096444)
@@ -36,6 +42,8 @@ changes relative to sbcl-1.1.7:
their COMPLEX variants.
* optimization: On x86 targets, more uses of ALIEN-FUNCALL during cross
compilation now inline the INVOKE-WITH-SAVED-FP-AND-PC dance.
+ * optimization: ROOM no longer conses so egregiously on non-x86oid
+ systems.
changes in sbcl-1.1.7 relative to sbcl-1.1.6:
* enhancement: TRACE :PRINT-ALL handles multiple-valued forms.
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index c59b99b..ff6152b 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -613,8 +613,7 @@ list of the symbols :dynamic, :static, or :read-only."
(lambda (obj header size)
(when (= sb-vm:code-header-widetag header)
(funcall fn obj size)))
- space
- t)))
+ space)))
(declaim (inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
diff --git a/src/code/room.lisp b/src/code/room.lisp
index 12f2124..462474b 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -20,12 +20,15 @@
(def!struct (room-info (:make-load-form-fun just-dump-it-normally))
;; the name of this type
(name nil :type symbol)
- ;; kind of type (how we determine length)
+ ;; kind of type (how to reconstitute an object)
(kind (missing-arg)
- :type (member :lowtag :fixed :header :vector
- :string :code :closure :instance))
- ;; length if fixed-length, shift amount for element size if :VECTOR
- (length nil :type (or fixnum null))))
+ :type (member :other :closure :instance :list
+ :code :vector-nil :weak-pointer))))
+
+(defun room-info-type-name (info)
+ (if (specialized-array-element-type-properties-p info)
+ (saetp-primitive-type-name info)
+ (room-info-name info)))
(eval-when (:compile-toplevel :execute)
@@ -34,24 +37,13 @@
(dolist (obj *primitive-objects*)
(let ((widetag (primitive-object-widetag obj))
(lowtag (primitive-object-lowtag obj))
- (name (primitive-object-name obj))
- (variable (primitive-object-variable-length-p obj))
- (size (primitive-object-size obj)))
- (cond
- ((not lowtag))
- ((not widetag)
- (let ((info (make-room-info :name name
- :kind :lowtag))
- (lowtag (symbol-value lowtag)))
- (declare (fixnum lowtag))
- (dotimes (i 32)
- (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
- (variable)
- (t
+ (name (primitive-object-name obj)))
+ (when (and (eq lowtag 'other-pointer-lowtag)
+ (not (member widetag '(t nil)))
+ (not (eq name 'weak-pointer)))
(setf (svref *meta-room-info* (symbol-value widetag))
(make-room-info :name name
- :kind :fixed
- :length size))))))
+ :kind :other)))))
(dolist (code (list #!+sb-unicode complex-character-string-widetag
complex-base-string-widetag simple-array-widetag
@@ -59,32 +51,24 @@
complex-array-widetag complex-vector-nil-widetag))
(setf (svref *meta-room-info* code)
(make-room-info :name 'array-header
- :kind :header)))
+ :kind :other)))
(setf (svref *meta-room-info* bignum-widetag)
(make-room-info :name 'bignum
- :kind :header))
+ :kind :other))
(setf (svref *meta-room-info* closure-header-widetag)
(make-room-info :name 'closure
:kind :closure))
(dotimes (i (length *specialized-array-element-type-properties*))
- (let* ((saetp (aref *specialized-array-element-type-properties* i))
- (array-kind (if (characterp (saetp-initial-element-default saetp))
- :string
- :vector))
- (element-shift (- (integer-length (saetp-n-bits saetp)) 4)))
+ (let ((saetp (aref *specialized-array-element-type-properties* i)))
(when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case.
- (setf (svref *meta-room-info* (saetp-typecode saetp))
- (make-room-info :name (saetp-primitive-type-name saetp)
- :kind array-kind
- :length element-shift)))))
+ (setf (svref *meta-room-info* (saetp-typecode saetp)) saetp))))
(setf (svref *meta-room-info* simple-array-nil-widetag)
(make-room-info :name 'simple-array-nil
- :kind :fixed
- :length 2))
+ :kind :vector-nil))
(setf (svref *meta-room-info* code-header-widetag)
(make-room-info :name 'code
@@ -98,9 +82,56 @@
(make-room-info :name 'funcallable-instance
:kind :closure))
+(setf (svref *meta-room-info* weak-pointer-widetag)
+ (make-room-info :name 'weak-pointer
+ :kind :weak-pointer))
+
+(let ((cons-info (make-room-info :name 'cons
+ :kind :list)))
+ ;; A cons consists of two words, both of which may be either a
+ ;; pointer or immediate data. Disregarding the possibility of an
+ ;; unbound-marker (permitted, according to the GC), this means
+ ;; either a fixnum, a character, a single-float on a 64-bit system,
+ ;; or a pointer.
+ (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
+ (setf (svref *meta-room-info* (ash i n-fixnum-tag-bits)) cons-info))
+
+ (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
+ (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
+ instance-pointer-lowtag))
+ cons-info)
+ (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
+ list-pointer-lowtag))
+ cons-info)
+ (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
+ fun-pointer-lowtag))
+ cons-info)
+ (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
+ other-pointer-lowtag))
+ cons-info))
+
+ (setf (svref *meta-room-info* character-widetag) cons-info)
+
+ ;; Single-floats are immediate data on 64-bit systems.
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (setf (svref *meta-room-info* single-float-widetag) cons-info))
+
) ; EVAL-WHEN
-(defparameter *room-info* '#.*meta-room-info*)
+(defparameter *room-info*
+ ;; SAETP instances don't dump properly from XC (or possibly
+ ;; normally), and we'd rather share structure with the master copy
+ ;; if we can anyway, so...
+ (make-array 256
+ :initial-contents
+ #.`(list
+ ,@(map 'list
+ (lambda (info)
+ (if (specialized-array-element-type-properties-p info)
+ `(aref *specialized-array-element-type-properties*
+ ,(position info *specialized-array-element-type-properties*))
+ info))
+ *meta-room-info*))))
(deftype spaces () '(member :static :dynamic :read-only))
;;;; MAP-ALLOCATED-OBJECTS
@@ -136,20 +167,127 @@
(defun round-to-dualword (size)
(logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
-;;; Return the total size of a vector in bytes, including any pad.
-#!-sb-fluid (declaim (inline vector-total-size))
-(defun vector-total-size (obj info)
- (let ((shift (room-info-length info))
- (len (+ (length (the (simple-array * (*)) obj))
- (ecase (room-info-kind info)
- (:vector 0)
- (:string 1)))))
- (round-to-dualword
- (+ (* vector-data-offset n-word-bytes)
- (if (minusp shift)
- (ash (+ len (1- (ash 1 (- shift))))
- shift)
- (ash len shift))))))
+;;; Return the vector OBJ, its WIDETAG, and the number of octets
+;;; required for its storage (including padding and alignment).
+(defun reconstitute-vector (obj saetp)
+ (declare (type (simple-array * (*)) obj)
+ (type specialized-array-element-type-properties saetp))
+ (let* ((length (+ (length obj)
+ (saetp-n-pad-elements saetp)))
+ (n-bits (saetp-n-bits saetp))
+ (alignment-pad (floor 7 n-bits))
+ (n-data-octets (if (>= n-bits 8)
+ (* length (ash n-bits -3))
+ (ash (* (+ length alignment-pad)
+ n-bits)
+ -3))))
+ (values obj
+ (saetp-typecode saetp)
+ (round-to-dualword (+ (* vector-data-offset n-word-bytes)
+ n-data-octets)))))
+
+;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
+;;; of a lisp object, return the object, its "type code" (either
+;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
+;;; required for its storage (including padding and alignment). Note
+;;; that this function is designed to NOT CONS, even if called
+;;; out-of-line.
+(defun reconstitute-object (address)
+ (let* ((object-sap (int-sap (get-lisp-obj-address address)))
+ (header (sap-ref-word object-sap 0))
+ (widetag (logand header widetag-mask))
+ (header-value (ash header (- n-widetag-bits)))
+ (info (svref *room-info* widetag)))
+ (symbol-macrolet
+ ((boxed-size (round-to-dualword (ash (1+ header-value) word-shift))))
+ (macrolet
+ ((tagged-object (tag)
+ `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
+ (cond
+ ;; Pick off arrays, as they're the only plausible cause for
+ ;; a non-nil, non-ROOM-INFO object as INFO.
+ ((specialized-array-element-type-properties-p info)
+ (reconstitute-vector (tagged-object other-pointer-lowtag) info))
+
+ ((null info)
+ (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
+ widetag))
+
+ ((eq (room-info-kind info) :list)
+ (values (tagged-object list-pointer-lowtag)
+ list-pointer-lowtag
+ (* 2 n-word-bytes)))
+
+ ((eq (room-info-kind info) :closure)
+ (values (tagged-object fun-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :instance)
+ (values (tagged-object instance-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :other)
+ (values (tagged-object other-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :vector-nil)
+ (values (tagged-object other-pointer-lowtag)
+ simple-array-nil-widetag
+ (* 2 n-word-bytes)))
+
+ ((eq (room-info-kind info) :weak-pointer)
+ (values (tagged-object other-pointer-lowtag)
+ weak-pointer-widetag
+ (round-to-dualword
+ (* weak-pointer-size
+ n-word-bytes))))
+
+ ((eq (room-info-kind info) :code)
+ (values (tagged-object other-pointer-lowtag)
+ code-header-widetag
+ (round-to-dualword
+ (* (+ header-value
+ (the fixnum
+ (sap-ref-lispobj object-sap
+ (* code-code-size-slot
+ n-word-bytes))))
+ n-word-bytes))))
+
+ (t
+ (error "Unrecognized room-info-kind ~S in reconstitute-object"
+ (room-info-kind info))))))))
+
+;;; Iterate over all the objects in the contiguous block of memory
+;;; with the low address at START and the high address just before
+;;; END, calling FUN with the object, the object's type code, and the
+;;; object's total size in bytes, including any header and padding.
+;;; START and END are untagged, aligned memory addresses interpreted
+;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
+(defun map-objects-in-range (fun start end)
+ (declare (type function fun))
+ ;; If START is (unsigned) greater than END, then we have somehow
+ ;; blown past our endpoint.
+ (aver (<= (get-lisp-obj-address start)
+ (get-lisp-obj-address end)))
+ (unless (= start end)
+ (multiple-value-bind
+ (obj typecode size)
+ (reconstitute-object start)
+ (aver (zerop (logand n-lowtag-bits size)))
+ (let ((next-start
+ ;; This special little dance is to add a number of octets
+ ;; (and it had best be a number evenly divisible by our
+ ;; allocation granularity) to an unboxed, aligned address
+ ;; masquerading as a fixnum. Without consing.
+ (%make-lisp-obj
+ (mask-field (byte #.n-word-bits 0)
+ (+ (get-lisp-obj-address start)
+ size)))))
+ (funcall fun obj typecode size)
+ (map-objects-in-range fun next-start end)))))
;;; Access to the GENCGC page table for better precision in
;;; MAP-ALLOCATED-OBJECTS
@@ -170,6 +308,8 @@
(gen (signed 8))))
(declaim (inline find-page-index))
(define-alien-routine "find_page_index" long (index signed))
+ (define-alien-variable "last_free_page" sb!kernel::page-index-t)
+ (define-alien-variable "heap_base" (* t))
(define-alien-variable "page_table" (* (struct page))))
;;; Iterate over all the objects allocated in SPACE, calling FUN with
@@ -179,146 +319,77 @@
;;; is intended for slightly more demanding uses of heap groveling
;;; then ROOM.
#!-sb-fluid (declaim (maybe-inline map-allocated-objects))
-(defun map-allocated-objects (fun space &optional careful)
- (declare (type function fun) (type spaces space))
- (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
- (flet ((make-obj (tagged-address)
- (if careful
- (make-lisp-obj tagged-address nil)
- (values (%make-lisp-obj tagged-address) t))))
- ;; Inlining MAKE-OBJ reduces consing on platforms where dynamic
- ;; space extends past fixnum range.
- (declare (inline make-obj))
- (without-gcing
- (multiple-value-bind (start end) (space-bounds space)
- (declare (type system-area-pointer start end))
- (declare (optimize (speed 3)))
- (let ((current start)
- #!+gencgc
- (skip-tests-until-addr 0))
- (labels ((maybe-finish-mapping ()
- (unless (sap< current end)
- (aver (sap= current end))
- (return-from map-allocated-objects)))
- ;; GENCGC doesn't allocate linearly, which means that the
- ;; dynamic space can contain large blocks zeros that get
- ;; accounted as conses in ROOM (and slow down other
- ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
- ;; check the GC page structure for the current address.
- ;; If the page is free or the address is beyond the page-
- ;; internal allocation offset (bytes-used) skip to the
- ;; next page immediately.
- (maybe-skip-page ()
- #!+gencgc
- (when (eq space :dynamic)
- (loop with page-mask = #.(1- sb!vm:gencgc-card-bytes)
- for addr of-type sb!vm:word = (sap-int current)
- while (>= addr skip-tests-until-addr)
- do
- ;; For some reason binding PAGE with LET
- ;; conses like mad (but gives no compiler notes...)
- ;; Work around the problem with SYMBOL-MACROLET
- ;; instead of trying to figure out the real
- ;; issue. -- JES, 2005-05-17
- (symbol-macrolet
- ((page (deref page-table
- (find-page-index addr))))
- ;; Don't we have any nicer way to access C struct
- ;; bitfields?
- (let ((alloc-flag (ldb (byte 3 2)
- (slot page 'flags)))
- (bytes-used (slot page 'bytes-used)))
- ;; If the page is not free and the current
- ;; pointer is still below the allocation offset
- ;; of the page
- (when (and (not (zerop alloc-flag))
- (< (logand page-mask addr)
- bytes-used))
- ;; Don't bother testing again until we
- ;; get past that allocation offset
- (setf skip-tests-until-addr
- (+ (logandc2 addr page-mask) bytes-used))
- ;; And then continue with the
- ;; scheduled mapping
- (return-from maybe-skip-page))
- ;; Move CURRENT to start of next page.
- (setf current (int-sap (+ (logandc2 addr page-mask)
- sb!vm:gencgc-card-bytes)))
- (maybe-finish-mapping))))))
- (maybe-map (obj obj-tag n-obj-bytes &optional (ok t))
- (let ((next (typecase n-obj-bytes
- (fixnum (sap+ current n-obj-bytes))
- (integer (sap+ current n-obj-bytes)))))
- ;; If this object would take us past END, it must
- ;; be either bogus, or it has been allocated after
- ;; the call to M-A-O.
- (cond ((and ok next (sap<= next end))
- (funcall fun obj obj-tag n-obj-bytes)
- (setf current next))
- (t
- (setf current (sap+ current n-word-bytes)))))))
- (declare (inline maybe-finish-mapping maybe-skip-page maybe-map))
- (loop
- (maybe-finish-mapping)
- (maybe-skip-page)
- (let* ((header (sap-ref-word current 0))
- (header-widetag (logand header #xFF))
- (info (svref *room-info* header-widetag)))
- (cond
- ((or (not info)
- (eq (room-info-kind info) :lowtag))
- (multiple-value-bind (obj ok)
- (make-obj (logior (sap-int current) list-pointer-lowtag))
- (maybe-map obj
- list-pointer-lowtag
- (* cons-size n-word-bytes)
- ok)))
- ((eq (room-info-kind info) :closure)
- (let* ((obj (%make-lisp-obj (logior (sap-int current)
- fun-pointer-lowtag)))
- (size (round-to-dualword
- (* (the fixnum (1+ (get-closure-length obj)))
- n-word-bytes))))
- (maybe-map obj header-widetag size)))
- ((eq (room-info-kind info) :instance)
- (let* ((obj (%make-lisp-obj
- (logior (sap-int current) instance-pointer-lowtag)))
- (size (round-to-dualword
- (* (+ (%instance-length obj) 1) n-word-bytes))))
- (aver (zerop (logand size lowtag-mask)))
- (maybe-map obj header-widetag size)))
- (t
- (multiple-value-bind (obj ok)
- (make-obj (logior (sap-int current) other-pointer-lowtag))
- (let ((size (when ok
- (ecase (room-info-kind info)
- (:fixed
- (aver (or (eql (room-info-length info)
- (1+ (get-header-data obj)))
- (floatp obj)
- (simple-array-nil-p obj)))
- (round-to-dualword
- (* (room-info-length info) n-word-bytes)))
- ((:vector :string)
- (vector-total-size obj info))
- (:header
- (round-to-dualword
- (* (1+ (get-header-data obj)) n-word-bytes)))
- (:code
- (+ (the fixnum
- (* (get-header-data obj) n-word-bytes))
- (round-to-dualword
- (* (the fixnum (%code-code-size obj))
- n-word-bytes))))))))
- (macrolet ((frob ()
- '(progn
- (when size (aver (zerop (logand size lowtag-mask))))
- (maybe-map obj header-widetag size))))
- (typecase size
- (fixnum (frob))
- (word (frob))
- (null (frob))))))))))))))))
+(defun map-allocated-objects (fun space)
+ (declare (type function fun)
+ (type spaces space))
+ (without-gcing
+ (ecase space
+ (:static
+ ;; Static space starts with NIL, which requires special
+ ;; handling, as the header and alignment are slightly off.
+ (multiple-value-bind (start end) (space-bounds space)
+ (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
+ (map-objects-in-range fun
+ (%make-lisp-obj (+ (* 8 n-word-bytes)
+ (sap-int start)))
+ (%make-lisp-obj (sap-int end)))))
+ ((:read-only #!-gencgc :dynamic)
+ ;; Read-only space (and dynamic space on cheneygc) is a block
+ ;; of contiguous allocations.
+ (multiple-value-bind (start end) (space-bounds space)
+ (map-objects-in-range fun
+ (%make-lisp-obj (sap-int start))
+ (%make-lisp-obj (sap-int end)))))
+
+ #!+gencgc
+ (:dynamic
+ ;; Dynamic space on gencgc requires walking the GC page tables
+ ;; in order to determine what regions contain objects.
+
+ ;; We explicitly presume that any pages in an allocation region
+ ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
+ ;; (indicating a full page) or an otherwise-valid BYTES-USED.
+ ;; We also presume that the pages of an open allocation region
+ ;; after the first page, and any pages that are unallocated,
+ ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
+
+ ;; Our procedure is to scan forward through the page table,
+ ;; maintaining an "end pointer" until we reach a page where
+ ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
+ ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
+ ;; is not empty, and proceed to the next page (unless we've hit
+ ;; LAST-FREE-PAGE). We happily take advantage of the fact that
+ ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
+ ;; coincident pointers for the range.
+
+ ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
+ ;; closing allocation regions and opening new ones. This may
+ ;; prove to be an issue with concurrent systems, or with
+ ;; spectacularly poor timing for closing an allocation region
+ ;; in a single-threaded system.
+
+ (loop
+ with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
+ ;; This magic dance gets us an unboxed aligned pointer as a
+ ;; FIXNUM.
+ with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
+ with end = start
+
+ ;; This is our page range.
+ for page-index from 0 below last-free-page
+ for next-page-addr from (+ start page-size) by page-size
+ for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
+
+ when (< page-bytes-used gencgc-card-bytes)
+ do (progn
+ (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
+ (map-objects-in-range fun start end)
+ (setf start next-page-addr)
+ (setf end next-page-addr))
+ else do (incf end page-size)
+
+ finally (map-objects-in-range fun start end))))))
;;;; MEMORY-USAGE
@@ -339,7 +410,7 @@
(let ((total-count (aref counts i)))
(unless (zerop total-count)
(let* ((total-size (aref sizes i))
- (name (room-info-name (aref *room-info* i)))
+ (name (room-info-type-name (aref *room-info* i)))
(found (gethash name totals)))
(cond (found
(incf (first found) total-size)
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index ec21162..f755b80 100644
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -221,7 +221,7 @@ static inline boolean protect_page_p(page_index_t page, generation_index_t gener
/* To map addresses to page structures the address of the first page
* is needed. */
-static void *heap_base = NULL;
+void *heap_base = NULL;
/* Calculate the start address for the given page number. */
inline void *
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|