X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=b94d9d85b51b71febcf958397b877ac8277011cc;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=6033ac0f36afe5e7391f4615fb789982c34cad4b;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 6033ac0..b94d9d8 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -10,6 +10,9 @@ ;;;; files for more information. (in-package "SB!VM") + +(declaim (special sb!vm:*read-only-space-free-pointer* + sb!vm:*static-space-free-pointer*)) ;;;; type format database @@ -17,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) @@ -31,46 +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)) - (;; KLUDGE described in dan_b message "Another one for the - ;; collection [bug 108]" (sbcl-devel 2004-01-22) - ;; - ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes - ;; debugger invoked on a SB-INT:BUG in thread 5911: - ;; failed AVER: "(SAP= CURRENT END)" - ;; [WHN: Similar things happened on one but not the other of my - ;; machines when I just run ROOM a lot in a loop.] - ;; - ;; This appears to be due to my [DB] abuse of the primitive - ;; object macros to define a thread object that shares a lowtag - ;; with fixnums and has no widetag: it looks like the code that - ;; generates *META-ROOM-INFO* infers from this that even fixnums - ;; are thread-sized - probably undesirable. - ;; - ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the - ;; nature of a workaround than a really good fix. I'm not sure - ;; what a really good fix is: I /think/ it's probably to remove - ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach - ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros - ;; for assembly source in the runtime/genesis/*.h files. - (eql name 'thread)) - ((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 @@ -78,67 +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)) -(dolist (stuff '((simple-bit-vector-widetag . -3) - (simple-vector-widetag . 2) - (simple-array-unsigned-byte-2-widetag . -2) - (simple-array-unsigned-byte-4-widetag . -1) - (simple-array-unsigned-byte-7-widetag . 0) - (simple-array-unsigned-byte-8-widetag . 0) - (simple-array-unsigned-byte-15-widetag . 1) - (simple-array-unsigned-byte-16-widetag . 1) - (simple-array-unsigned-byte-31-widetag . 2) - (simple-array-unsigned-byte-32-widetag . 2) - (simple-array-unsigned-byte-60-widetag . 3) - (simple-array-unsigned-byte-63-widetag . 3) - (simple-array-unsigned-byte-64-widetag . 3) - (simple-array-signed-byte-8-widetag . 0) - (simple-array-signed-byte-16-widetag . 1) - (simple-array-unsigned-byte-29-widetag . 2) - (simple-array-signed-byte-30-widetag . 2) - (simple-array-signed-byte-32-widetag . 2) - (simple-array-signed-byte-61-widetag . 3) - (simple-array-signed-byte-64-widetag . 3) - (simple-array-single-float-widetag . 2) - (simple-array-double-float-widetag . 3) - (simple-array-complex-single-float-widetag . 3) - (simple-array-complex-double-float-widetag . 4))) - (let* ((name (car stuff)) - (size (cdr stuff)) - (sname (string name))) - (when (boundp name) - (setf (svref *meta-room-info* (symbol-value name)) - (make-room-info :name (intern (subseq sname - 0 - (mismatch sname "-WIDETAG" - :from-end t))) - :kind :vector - :length size))))) - -(setf (svref *meta-room-info* simple-base-string-widetag) - (make-room-info :name 'simple-base-string - :kind :string - :length 0)) - -#!+sb-unicode -(setf (svref *meta-room-info* simple-character-string-widetag) - (make-room-info :name 'simple-character-string - :kind :string - :length 2)) +(dotimes (i (length *specialized-array-element-type-properties*)) + (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)) 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 @@ -148,9 +78,61 @@ (make-room-info :name 'instance :kind :instance)) +(setf (svref *meta-room-info* funcallable-instance-header-widetag) + (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. According to the runtime this means + ;; either a fixnum, a character, an unbound-marker, 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) + + (setf (svref *meta-room-info* unbound-marker-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 @@ -166,10 +148,10 @@ (ecase space (:static (values (int-sap static-space-start) - (int-sap (* *static-space-free-pointer* n-word-bytes)))) + (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits)))) (:read-only (values (int-sap read-only-space-start) - (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) + (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits)))) (:dynamic (values (int-sap (current-dynamic-space-start)) (dynamic-space-free-pointer))))) @@ -179,127 +161,247 @@ (multiple-value-bind (start end) (space-bounds space) (- (sap-int end) (sap-int start)))) -;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary. +;;; 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 +;;; platforms with 64-bit word size. #!-sb-fluid (declaim (inline round-to-dualword)) (defun round-to-dualword (size) - (declare (fixnum size)) - (logand (the fixnum (+ 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))))) - (declare (type (integer -3 3) shift)) - (round-to-dualword - (+ (* vector-data-offset n-word-bytes) - (the fixnum - (if (minusp shift) - (ash (the fixnum - (+ len (the fixnum - (1- (the fixnum (ash 1 (- shift))))))) - shift) - (ash len shift))))))) + (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask))) + +;;; 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 +#!+gencgc +(progn + (define-alien-type (struct page) + (struct page + (start signed) + ;; On platforms with small enough GC pages, this field + ;; will be a short. On platforms with larger ones, it'll + ;; be an int. + (bytes-used (unsigned + #.(if (typep sb!vm:gencgc-card-bytes + '(unsigned-byte 16)) + 16 + 32))) + (flags (unsigned 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 ;;; the object, the object's type code, and the object's total size in -;;; bytes, including any header and padding. +;;; bytes, including any header and padding. CAREFUL makes +;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it +;;; 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) - (declare (type function fun) (type spaces space)) + (declare (type function fun) + (type spaces space)) (without-gcing - (multiple-value-bind (start end) (space-bounds space) - (declare (type system-area-pointer start end)) - (declare (optimize (speed 3) (safety 0))) - (let ((current start) - #+nil - (prev nil)) - (loop - (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)) - (let ((size (* cons-size n-word-bytes))) - (funcall fun - (make-lisp-obj (logior (sap-int current) - list-pointer-lowtag)) - list-pointer-lowtag - size) - (setq current (sap+ current size)))) - ((eql header-widetag closure-header-widetag) - (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)))) - (funcall fun obj header-widetag size) - (setq current (sap+ current 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)))) - (declare (fixnum size)) - (funcall fun obj header-widetag size) - (aver (zerop (logand size lowtag-mask))) - #+nil - (when (> size 200000) (break "implausible size, prev ~S" prev)) - #+nil - (setq prev current) - (setq current (sap+ current size)))) - (t - (let* ((obj (make-lisp-obj - (logior (sap-int current) other-pointer-lowtag))) - (size (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))))))) - (declare (fixnum size)) - (funcall fun obj header-widetag size) - (aver (zerop (logand size lowtag-mask))) - #+nil - (when (> size 200000) - (break "Implausible size, prev ~S" prev)) - #+nil - (setq prev current) - (setq current (sap+ current size)))))) - (unless (sap< current end) - (aver (sap= current end)) - (return))) - - #+nil - prev)))) + (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 ;;; Return a list of 3-lists (bytes object type-name) for the objects ;;; allocated in Space. (defun type-breakdown (space) - (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum)) - (counts (make-array 256 :initial-element 0 :element-type 'fixnum))) + (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))) + (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj)) + (declare (word size) (optimize (speed 3)) (ignore obj)) (incf (aref sizes type) size) (incf (aref counts type))) space) @@ -309,7 +411,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) @@ -339,7 +441,7 @@ (maphash (lambda (k v) (declare (ignore k)) (let ((sum 0)) - (declare (fixnum sum)) + (declare (unsigned-byte sum)) (dolist (space-total v) (incf sum (first (cdr space-total)))) (summary-totals (cons sum v)))) @@ -348,13 +450,13 @@ (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces) (let ((summary-total-bytes 0) (summary-total-objects 0)) - (declare (fixnum summary-total-bytes summary-total-objects)) + (declare (unsigned-byte summary-total-bytes summary-total-objects)) (dolist (space-totals (mapcar #'cdr (sort (summary-totals) #'> :key #'car))) (let ((total-objects 0) (total-bytes 0) name) - (declare (fixnum total-objects total-bytes)) + (declare (unsigned-byte total-objects total-bytes)) (collect ((spaces)) (dolist (space-total space-totals) (let ((total (cdr space-total))) @@ -386,8 +488,8 @@ 0)) (reported-bytes 0) (reported-objects 0)) - (declare (fixnum total-objects total-bytes cutoff-point reported-objects - reported-bytes)) + (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects + reported-bytes)) (loop for (bytes objects name) in types do (when (<= bytes cutoff-point) (format t " ~10:D bytes for ~9:D other object~2:*~P.~%" @@ -438,12 +540,12 @@ (type unsigned-byte total-bytes)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size) (optimize (safety 0))) (when (eql type code-header-widetag) - (incf total-bytes size) (let ((words (truly-the fixnum (%code-code-size obj))) - (sap (truly-the system-area-pointer - (%primitive code-instructions obj)))) + (sap (%primitive code-instructions obj)) + (size size)) + (declare (fixnum size)) + (incf total-bytes size) (incf code-words words) (dotimes (i words) (when (zerop (sap-ref-word sap (* i n-word-bytes))) @@ -467,11 +569,11 @@ (declare (inline map-allocated-objects)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size) (optimize (safety 0))) (case type (#.code-header-widetag - (let ((inst-words (truly-the fixnum (%code-code-size obj)))) - (declare (type fixnum inst-words)) + (let ((inst-words (truly-the fixnum (%code-code-size obj))) + (size size)) + (declare (type fixnum size inst-words)) (incf non-descriptor-bytes (* inst-words n-word-bytes)) (incf descriptor-words (- (truncate size n-word-bytes) inst-words)))) @@ -489,7 +591,6 @@ #.simple-array-unsigned-byte-32-widetag #.simple-array-signed-byte-8-widetag #.simple-array-signed-byte-16-widetag - ; #.simple-array-signed-byte-30-widetag #.simple-array-signed-byte-32-widetag #.simple-array-single-float-widetag #.simple-array-double-float-widetag @@ -515,7 +616,7 @@ #.sap-widetag #.weak-pointer-widetag #.instance-header-widetag) - (incf descriptor-words (truncate size n-word-bytes))) + (incf descriptor-words (truncate (the fixnum size) n-word-bytes))) (t (error "bogus widetag: ~W" type)))) space)) @@ -534,15 +635,17 @@ (let ((totals (make-hash-table :test 'eq)) (total-objects 0) (total-bytes 0)) - (declare (fixnum total-objects total-bytes)) + (declare (unsigned-byte total-objects total-bytes)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size) (optimize (speed 3) (safety 0))) + (declare (optimize (speed 3))) (when (eql type instance-header-widetag) (incf total-objects) - (incf total-bytes size) (let* ((classoid (layout-classoid (%instance-ref obj 0))) - (found (gethash classoid totals))) + (found (gethash classoid totals)) + (size size)) + (declare (fixnum size)) + (incf total-bytes size) (cond (found (incf (the fixnum (car found))) (incf (the fixnum (cdr found)) size)) @@ -559,7 +662,7 @@ (let ((sorted (sort (totals-list) #'> :key #'cddr)) (printed-bytes 0) (printed-objects 0)) - (declare (fixnum printed-bytes printed-objects)) + (declare (unsigned-byte printed-bytes printed-objects)) (dolist (what (if top-n (subseq sorted 0 (min (length sorted) top-n)) sorted)) @@ -608,7 +711,6 @@ (note-conses (cdr x))))) (map-allocated-objects (lambda (obj obj-type size) - (declare (optimize (safety 0))) (let ((addr (get-lisp-obj-address obj))) (when (>= addr start) (when (if count @@ -689,7 +791,6 @@ (let ((res ())) (map-allocated-objects (lambda (obj obj-type size) - (declare (optimize (safety 0))) (when (and (or (not type) (eql obj-type type)) (or (not smaller) (<= size smaller)) (or (not larger) (>= size larger)) @@ -700,6 +801,26 @@ space) res))) +;;; Calls FUNCTION with all object that have (possibly conservative) +;;; references to them on current stack. +(defun map-stack-references (function) + (let ((end + (sb!di::descriptor-sap + #!+stack-grows-downward-not-upward *control-stack-end* + #!-stack-grows-downward-not-upward *control-stack-start*)) + (sp (current-sp)) + (seen nil)) + (loop until #!+stack-grows-downward-not-upward (sap> sp end) + #!-stack-grows-downward-not-upward (sap< sp end) + do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil) + (when (and ok (typep obj '(not (or fixnum character)))) + (unless (member obj seen :test #'eq) + (funcall function obj) + (push obj seen)))) + (setf sp + #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes) + #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes)))))) + (defun map-referencing-objects (fun space object) (declare (type spaces space) (inline map-allocated-objects)) (unless *ignore-after* @@ -709,7 +830,7 @@ (funcall fun obj)))) (map-allocated-objects (lambda (obj obj-type size) - (declare (optimize (safety 0)) (ignore obj-type size)) + (declare (ignore obj-type size)) (typecase obj (cons (when (or (eq (car obj) object) @@ -736,7 +857,8 @@ (when (or (eq (symbol-name obj) object) (eq (symbol-package obj) object) (eq (symbol-plist obj) object) - (eq (symbol-value obj) object)) + (and (boundp obj) + (eq (symbol-value obj) object))) (maybe-call fun obj))))) space)))