X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=8331d71877876f3768154d89a367f79ba7130369;hb=0338d1fc97a74b8ff332821ea275120b9de951c1;hp=6033ac0f36afe5e7391f4615fb789982c34cad4b;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 6033ac0..8331d71 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 @@ -36,28 +39,6 @@ (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)) @@ -88,8 +69,10 @@ (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 . 2) + (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) @@ -98,15 +81,13 @@ (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-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-unsigned-byte-29-widetag . 2) - (simple-array-signed-byte-30-widetag . 2) + (simple-array-fixnum-widetag . #.sb!vm:word-shift) (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) @@ -148,6 +129,10 @@ (make-room-info :name 'instance :kind :instance)) +(setf (svref *meta-room-info* funcallable-instance-header-widetag) + (make-room-info :name 'funcallable-instance + :kind :closure)) + ) ; EVAL-WHEN (defparameter *room-info* '#.*meta-room-info*) @@ -166,10 +151,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,11 +164,12 @@ (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))) + (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)) @@ -193,113 +179,192 @@ (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))))))) + (if (minusp shift) + (ash (+ len (1- (ash 1 (- shift)))) + shift) + (ash len shift)))))) + +;;; 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 "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) +(defun map-allocated-objects (fun space &optional careful) (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)))) + (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)))))))))))))))) + ;;;; 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) @@ -339,7 +404,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 +413,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 +451,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 +503,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 +532,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 +554,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 +579,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 +598,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 +625,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 +674,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 +754,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 +764,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 +793,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 +820,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)))