X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=b94d9d85b51b71febcf958397b877ac8277011cc;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=ea2f30990eb79181ac03cd87b2e727b6c562b664;hpb=fd225cfc39c6e4ba6f778b4201423cd3e83e0418;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index ea2f309..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,30 +161,134 @@ (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 @@ -210,152 +296,112 @@ (progn (define-alien-type (struct page) (struct page - (start long) - (bytes-used (unsigned 16)) + (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 long)) - (define-alien-variable "page_table" - (array (struct page) - #.(truncate (- dynamic-space-end - dynamic-space-start) - sb!vm:gencgc-page-size)))) + (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) - #!+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-page-size) - 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) - (the fixnum 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-page-size))) - (maybe-finish-mapping))))))) - (declare (inline maybe-finish-mapping maybe-skip-page)) - (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)) - (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))) - (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))) - (setq current (sap+ current size)))))))))))) - + (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) @@ -365,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) @@ -395,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)))) @@ -404,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))) @@ -442,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.~%" @@ -494,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))) @@ -523,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)))) @@ -545,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 @@ -571,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)) @@ -590,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)) @@ -615,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)) @@ -664,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 @@ -745,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)) @@ -756,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* @@ -765,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) @@ -792,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)))