X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=b94d9d85b51b71febcf958397b877ac8277011cc;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=3ddbfc6d790b5ef67beca904ea2649405168dd2d;hpb=05bb9b2b4ff04fb85067aa31c84d205b7a00c390;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 3ddbfc6..b94d9d8 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,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 @@ -81,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)) -;; FIXME: This looks rather brittle. Can we get more of these numbers -;; from somewhere sensible? -(dolist (stuff '((simple-bit-vector-widetag . -3) - (simple-vector-widetag . #.sb!vm:word-shift) - (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-fixnum-widetag . #.sb!vm:word-shift) - (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-fixnum-widetag . #.sb!vm:word-shift) - (simple-array-signed-byte-32-widetag . 2) - (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 @@ -151,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 @@ -189,20 +168,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 @@ -210,7 +296,7 @@ (progn (define-alien-type (struct page) (struct page - (start long) + (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. @@ -222,7 +308,9 @@ (flags (unsigned 8)) (gen (signed 8)))) (declaim (inline find-page-index)) - (define-alien-routine "find_page_index" long (index long)) + (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 @@ -232,145 +320,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)) - (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))) - ((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)))) - (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 @@ -391,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)