From 2f4162683897dd64692e65f2b8f1e426e6a7a0cb Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 17 Aug 2017 19:39:43 -0400 Subject: [PATCH] Fix SB-VM::SPACE-BYTES to avoid consing SAPs Querying a space usage cost 4 words of allocation. Asking 100 times in a row on a 32-bit machine created 1 page full of garbage! --- src/code/alloc.lisp | 26 ++++++++----------- src/code/room.lisp | 65 +++++++++++++++++++++++++++------------------- tests/compiler-2.pure.lisp | 6 +++++ 3 files changed, 55 insertions(+), 42 deletions(-) diff --git a/src/code/alloc.lisp b/src/code/alloc.lisp index 9256fdc3b..7a71c90ed 100644 --- a/src/code/alloc.lisp +++ b/src/code/alloc.lisp @@ -372,31 +372,27 @@ '(member :fixed :variable)) (declaim (inline immobile-subspace-bounds)) +;;; Return fixnums in the same fashion as %SPACE-BOUNDS. (defun immobile-subspace-bounds (subspace) - ;; FIXME: this is a goofy return convention - primary value is sane, - ;; secondary has funny bit-shifted representation. - (macrolet ((munge-sap (sym) - `(ash (sap-int ,sym) (- n-fixnum-tag-bits)))) - (case subspace - (:fixed (values immobile-space-start - (munge-sap *immobile-fixedobj-free-pointer*))) - (:variable (values (+ immobile-space-start immobile-fixedobj-subspace-size) - (munge-sap *immobile-space-free-pointer*)))))) + (case subspace + (:fixed (values (%make-lisp-obj immobile-space-start) + (%make-lisp-obj (sap-int *immobile-fixedobj-free-pointer*)))) + (:variable (values (%make-lisp-obj (+ immobile-space-start + immobile-fixedobj-subspace-size)) + (%make-lisp-obj (sap-int *immobile-space-free-pointer*)))))) (declaim (ftype (sfunction (function &rest immobile-subspaces) null) map-immobile-objects)) -(defun map-immobile-objects (function &rest subspaces) +(defun map-immobile-objects (function &rest subspaces) ; Perform no filtering (do-rest-arg ((subspace) subspaces) - (multiple-value-bind (start free-pointer) - (immobile-subspace-bounds subspace) - (map-objects-in-range - function (ash start (- n-fixnum-tag-bits)) free-pointer)))) + (multiple-value-bind (start end) (immobile-subspace-bounds subspace) + (map-objects-in-range function start end)))) (declaim (ftype (function (immobile-subspaces) (values t t t &optional)) immobile-fragmentation-information)) (defun immobile-fragmentation-information (subspace) (binding* (((start free-pointer) (immobile-subspace-bounds subspace)) - (used-bytes (- (ash free-pointer n-fixnum-tag-bits) start)) + (used-bytes (ash (- free-pointer start) n-fixnum-tag-bits)) (holes '()) (hole-bytes 0)) (map-immobile-objects diff --git a/src/code/room.lisp b/src/code/room.lisp index 9aa068f38..44d52285b 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -159,27 +159,35 @@ sb!vm:dynamic-space-start #!-gencgc (extern-alien "current_dynamic_space" unsigned-long)) -(defun space-bounds (space) +;;; Return the lower limit and current free-pointer of SPACE as fixnums +;;; whose raw bits (at the register level) represent a pointer. +;;; This makes it "off" by a factor of (EXPT 2 N-FIXNUM-TAG-BITS) - and/or +;;; possibly negative - if you look at the value in Lisp, +;;; but avoids potentially needing a bignum on 32-bit machines. +;;; 64-bit machines have no problem since most current generation CPUs +;;; use an address width that is narrower than 64 bits. +;;; This function is private because of the wacky representation. +(defun %space-bounds (space) (declare (type spaces space)) (ecase space (:static - (values (int-sap static-space-start) - *static-space-free-pointer*)) + (values (%make-lisp-obj static-space-start) + (%make-lisp-obj (sap-int *static-space-free-pointer*)))) (:read-only - (values (int-sap read-only-space-start) - *read-only-space-free-pointer*)) + (values (%make-lisp-obj read-only-space-start) + (%make-lisp-obj (sap-int *read-only-space-free-pointer*)))) #!+immobile-space (:immobile - (values (int-sap immobile-space-start) - *immobile-space-free-pointer*)) + (values (%make-lisp-obj immobile-space-start) + (%make-lisp-obj (sap-int *immobile-space-free-pointer*)))) (:dynamic - (values (int-sap (current-dynamic-space-start)) - (dynamic-space-free-pointer))))) + (values (%make-lisp-obj (current-dynamic-space-start)) + (%make-lisp-obj (sap-int (dynamic-space-free-pointer))))))) ;;; Return the total number of bytes used in SPACE. (defun space-bytes (space) - (multiple-value-bind (start end) (space-bounds space) - (- (sap-int end) (sap-int start)))) + (multiple-value-bind (start end) (%space-bounds space) + (ash (- end start) n-fixnum-tag-bits))) ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on @@ -379,32 +387,35 @@ (: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) + (multiple-value-bind (start end) (%space-bounds space) + ;; This "8" is very magical. It happens to work for both + ;; word sizes, even though symbols differ in length + ;; (they can be either 6 or 7 words). (funcall fun nil symbol-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))))) + (+ (ash (* 8 n-word-bytes) (- n-fixnum-tag-bits)) + start) + 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))))) - + (multiple-value-bind (start end) (%space-bounds space) + (map-objects-in-range fun start end))) #!+immobile-space (:immobile ;; Filter out filler objects. These either look like cons cells ;; in fixedobj subspace, or code without enough header words ;; in varyobj subspace. (cf 'immobile_filler_p' in gc-internal.h) (dx-flet ((filter (obj type size) - (unless (or (and (code-component-p obj) - (eql (code-header-words obj) 2)) - (consp obj)) + (unless (consp obj) + (funcall fun obj type size)))) + (map-immobile-objects #'filter :fixed)) + (dx-flet ((filter (obj type size) + (unless (and (code-component-p obj) + (eql (code-header-words obj) 2)) (funcall fun obj type size)))) - (map-immobile-objects #'filter :fixed :variable))) + (map-immobile-objects #'filter :variable))) #!+gencgc (:dynamic @@ -667,9 +678,9 @@ (declare (type (integer 0 99) percent) (type index pages) (type stream stream) (type spaces space) (type (or index null) type larger smaller count)) - (multiple-value-bind (start-sap end-sap) (space-bounds space) - (let* ((space-start (sap-int start-sap)) - (space-end (sap-int end-sap)) + (multiple-value-bind (start end) (%space-bounds space) + (let* ((space-start (ash start n-fixnum-tag-bits)) + (space-end (ash end n-fixnum-tag-bits)) (space-size (- space-end space-start)) (pagesize (get-page-size)) (start (+ space-start (round (* space-size percent) 100))) diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp index 058d19332..1813bb0ad 100644 --- a/tests/compiler-2.pure.lisp +++ b/tests/compiler-2.pure.lisp @@ -147,6 +147,12 @@ (declare (optimize safety)) (princ-to-string x) x)))) (assert (ctu:find-named-callees f :name 'princ-to-string)))) +(with-test (:name :space-bounds-no-consing + :skipped-on :interpreter) + ;; Asking for the size of a heap space should not cost anything! + (ctu:assert-no-consing (sb-vm::%space-bounds :static)) + (ctu:assert-no-consing (sb-vm::space-bytes :static))) + (with-test (:name :map-allocated-objects-no-consing :skipped-on :interpreter :fails-on :ppc) -- 2.11.4.GIT