X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=3dc375eb91562ae226dc907c57341f1bdf22fc9b;hb=8d490a4d6b9d7f156cf503826b3e3195e6f3ad39;hp=fdebda6e5d2f73e1906486397160b6421d65bace;hpb=ba94fb1763a2f1e01a3b75a9e1415f051c5a559f;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index fdebda6..3dc375e 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -72,7 +72,8 @@ :kind :fixed :length size)))))) -(dolist (code (list complex-base-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-vector-nil-widetag)) (setf (svref *meta-room-info* code) @@ -97,11 +98,16 @@ (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) @@ -109,19 +115,26 @@ (let* ((name (car stuff)) (size (cdr stuff)) (sname (string 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)))) + (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)) + (setf (svref *meta-room-info* simple-array-nil-widetag) (make-room-info :name 'simple-array-nil :kind :fixed @@ -193,7 +206,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) @@ -206,7 +219,7 @@ #+nil (prev nil)) (loop - (let* ((header (sap-ref-32 current 0)) + (let* ((header (sap-ref-word current 0)) (header-widetag (logand header #xFF)) (info (svref *room-info* header-widetag))) (cond @@ -434,7 +447,7 @@ (%primitive code-instructions obj)))) (incf code-words words) (dotimes (i words) - (when (zerop (sap-ref-32 sap (* i n-word-bytes))) + (when (zerop (sap-ref-word sap (* i n-word-bytes))) (incf no-ops)))))) space) @@ -467,6 +480,7 @@ #.single-float-widetag #.double-float-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 @@ -476,7 +490,7 @@ #.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-30-widetag #.simple-array-signed-byte-32-widetag #.simple-array-single-float-widetag #.simple-array-double-float-widetag @@ -513,7 +527,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)) @@ -653,9 +667,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)) @@ -665,7 +684,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 @@ -681,34 +701,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)))