X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=c7696b221ed97b733b8bf8c2ae9f9ba6e480c0d6;hb=77d94d36bcfd3d5eea73ad51e6ee621a8938f995;hp=4dbefe7f41dd2eb4107f99f6dbc465325296ef7d;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 4dbefe7..c7696b2 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -36,6 +36,28 @@ (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)) @@ -50,9 +72,10 @@ :kind :fixed :length size)))))) -(dolist (code (list complex-string-widetag simple-array-widetag +(dolist (code (list #!+sb-unicode complex-character-string-widetag + complex-base-string-widetag simple-array-widetag complex-bit-vector-widetag complex-vector-widetag - complex-array-widetag)) + complex-array-widetag complex-vector-nil-widetag)) (setf (svref *meta-room-info* code) (make-room-info :name 'array-header :kind :header))) @@ -69,11 +92,15 @@ (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-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-single-float-widetag . 2) @@ -91,11 +118,17 @@ :kind :vector :length size)))) -(setf (svref *meta-room-info* simple-string-widetag) - (make-room-info :name 'simple-string +(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)) + (setf (svref *meta-room-info* simple-array-nil-widetag) (make-room-info :name 'simple-array-nil :kind :fixed @@ -132,7 +165,8 @@ (values (int-sap read-only-space-start) (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) (:dynamic - (values (int-sap dynamic-space-start) + (values (int-sap #!+gencgc dynamic-space-start + #!-gencgc (current-dynamic-space-start)) (dynamic-space-free-pointer))))) ;;; Return the total number of bytes used in SPACE. @@ -166,7 +200,7 @@ (ash len shift))))))) ;;; Iterate over all the objects allocated in SPACE, calling FUN with -;;; the object, the object's type code, and the objects total size in +;;; the object, the object's type code, and the object's total size in ;;; bytes, including any header and padding. #!-sb-fluid (declaim (maybe-inline map-allocated-objects)) (defun map-allocated-objects (fun space) @@ -439,7 +473,9 @@ ((#.bignum-widetag #.single-float-widetag #.double-float-widetag - #.simple-string-widetag + #.simple-base-string-widetag + #!+sb-unicode #.simple-character-string-widetag + #.simple-array-nil-widetag #.simple-bit-vector-widetag #.simple-array-unsigned-byte-2-widetag #.simple-array-unsigned-byte-4-widetag @@ -462,7 +498,8 @@ #.complex-widetag #.simple-array-widetag #.simple-vector-widetag - #.complex-string-widetag + #.complex-base-string-widetag + #.complex-vector-nil-widetag #.complex-bit-vector-widetag #.complex-vector-widetag #.complex-array-widetag @@ -484,7 +521,7 @@ (values))) ;;; Print a breakdown by instance type of all the instances allocated -;;; in SPACE. If TOP-N is true, print only information for the the +;;; in SPACE. If TOP-N is true, print only information for the ;;; TOP-N types with largest usage. (defun instance-usage (space &key (top-n 15)) (declare (type spaces space) (type (or fixnum null) top-n)) @@ -539,32 +576,6 @@ (values)) -(defun find-holes (&rest spaces) - (dolist (space (or spaces '(:read-only :static :dynamic))) - (format t "In ~A space:~%" space) - (let ((start-addr nil) - (total-bytes 0)) - (declare (type (or null (unsigned-byte 32)) start-addr) - (type (unsigned-byte 32) total-bytes)) - (map-allocated-objects - (lambda (object typecode bytes) - (declare (ignore typecode) - (type (unsigned-byte 32) bytes)) - (if (and (consp object) - (eql (car object) 0) - (eql (cdr object) 0)) - (if start-addr - (incf total-bytes bytes) - (setf start-addr (sb!di::get-lisp-obj-address object) - total-bytes bytes)) - (when start-addr - (format t "~:D bytes at #X~X~%" total-bytes start-addr) - (setf start-addr nil)))) - space) - (when start-addr - (format t "~:D bytes at #X~X~%" total-bytes start-addr)))) - (values)) - ;;;; PRINT-ALLOCATED-OBJECTS (defun print-allocated-objects (space &key (percent 0) (pages 5) @@ -650,9 +661,14 @@ (defvar *ignore-after* nil) +(defun valid-obj (space x) + (or (not (eq space :dynamic)) + ;; this test looks bogus if the allocator doesn't work linearly, + ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29 + (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))) + (defun maybe-cons (space x stuff) - (if (or (not (eq space :dynamic)) - (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))) + (if (valid-obj space x) (cons x stuff) stuff)) @@ -662,7 +678,8 @@ (type (or index null) larger smaller type count) (type (or function null) test) (inline map-allocated-objects)) - (unless *ignore-after* (setq *ignore-after* (cons 1 2))) + (unless *ignore-after* + (setq *ignore-after* (cons 1 2))) (collect ((counted 0 1+)) (let ((res ())) (map-allocated-objects @@ -678,34 +695,48 @@ space) res))) -(defun list-referencing-objects (space object) +(defun map-referencing-objects (fun space object) (declare (type spaces space) (inline map-allocated-objects)) - (unless *ignore-after* (setq *ignore-after* (cons 1 2))) - (let ((res ())) - (flet ((res (x) - (setq res (maybe-cons space x res)))) - (map-allocated-objects - (lambda (obj obj-type size) - (declare (optimize (safety 0)) (ignore obj-type size)) - (typecase obj - (cons - (when (or (eq (car obj) object) (eq (cdr obj) object)) - (res obj))) - (instance - (dotimes (i (%instance-length obj)) - (when (eq (%instance-ref obj i) object) - (res obj) - (return)))) - (simple-vector - (dotimes (i (length obj)) - (when (eq (svref obj i) object) - (res obj) - (return)))) - (symbol - (when (or (eq (symbol-name obj) object) - (eq (symbol-package obj) object) - (eq (symbol-plist obj) object) - (eq (symbol-value obj) object)) - (res obj))))) - space)) - res)) + (unless *ignore-after* + (setq *ignore-after* (cons 1 2))) + (flet ((maybe-call (fun obj) + (when (valid-obj space obj) + (funcall fun obj)))) + (map-allocated-objects + (lambda (obj obj-type size) + (declare (optimize (safety 0)) (ignore obj-type size)) + (typecase obj + (cons + (when (or (eq (car obj) object) + (eq (cdr obj) object)) + (maybe-call fun obj))) + (instance + (dotimes (i (%instance-length obj)) + (when (eq (%instance-ref obj i) object) + (maybe-call fun obj) + (return)))) + (code-component + (let ((length (get-header-data obj))) + (do ((i code-constants-offset (1+ i))) + ((= i length)) + (when (eq (code-header-ref obj i) object) + (maybe-call fun obj) + (return))))) + (simple-vector + (dotimes (i (length obj)) + (when (eq (svref obj i) object) + (maybe-call fun obj) + (return)))) + (symbol + (when (or (eq (symbol-name obj) object) + (eq (symbol-package obj) object) + (eq (symbol-plist obj) object) + (eq (symbol-value obj) object)) + (maybe-call fun obj))))) + space))) + +(defun list-referencing-objects (space object) + (collect ((res)) + (map-referencing-objects + (lambda (obj) (res obj)) space object) + (res)))