X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=4dbefe7f41dd2eb4107f99f6dbc465325296ef7d;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=b8d966e1d8e4e69108c83a356b9dc59e99b70522;hpb=89eb73c035f05ae53b1148ef8a83e1d4030b2dd8;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index b8d966e..4dbefe7 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -15,13 +15,13 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (def!struct (room-info (:make-load-form-fun just-dump-it-normally)) - ;; The name of this type. + ;; the name of this type (name nil :type symbol) - ;; Kind of type (how we determine length). - (kind (required-argument) + ;; kind of type (how we determine length) + (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 if fixed-length, shift amount for element size if :VECTOR (length nil :type (or fixnum null)))) (eval-when (:compile-toplevel :execute) @@ -32,7 +32,7 @@ (let ((widetag (primitive-object-widetag obj)) (lowtag (primitive-object-lowtag obj)) (name (primitive-object-name obj)) - (variable (primitive-object-var-length obj)) + (variable (primitive-object-variable-length-p obj)) (size (primitive-object-size obj))) (cond ((not lowtag)) @@ -80,18 +80,27 @@ (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))) + (let* ((name (car stuff)) + (size (cdr stuff)) + (sname (string name))) (setf (svref *meta-room-info* (symbol-value name)) - (make-room-info :name 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-string-widetag) - (make-room-info :name 'simple-string-widetag + (make-room-info :name 'simple-string :kind :string :length 0)) +(setf (svref *meta-room-info* simple-array-nil-widetag) + (make-room-info :name 'simple-array-nil + :kind :fixed + :length 2)) + (setf (svref *meta-room-info* code-header-widetag) (make-room-info :name 'code :kind :code)) @@ -100,7 +109,7 @@ (make-room-info :name 'instance :kind :instance)) -); eval-when (compile eval) +) ; EVAL-WHEN (defparameter *room-info* '#.*meta-room-info*) (deftype spaces () '(member :static :dynamic :read-only)) @@ -211,7 +220,8 @@ (:fixed (aver (or (eql (room-info-length info) (1+ (get-header-data obj))) - (floatp obj))) + (floatp obj) + (simple-array-nil-p obj))) (round-to-dualword (* (room-info-length info) n-word-bytes))) ((:vector :string) @@ -249,10 +259,10 @@ (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum)) (counts (make-array 256 :initial-element 0 :element-type 'fixnum))) (map-allocated-objects - #'(lambda (obj type size) - (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj)) - (incf (aref sizes type) size) - (incf (aref counts type))) + (lambda (obj type size) + (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj)) + (incf (aref sizes type) size) + (incf (aref counts type))) space) (let ((totals (make-hash-table :test 'eq))) @@ -270,9 +280,9 @@ (list total-size total-count name)))))))) (collect ((totals-list)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (totals-list v)) + (maphash (lambda (k v) + (declare (ignore k)) + (totals-list v)) totals) (sort (totals-list) #'> :key #'first))))) @@ -287,13 +297,13 @@ (gethash (third total) summary)))) (collect ((summary-totals)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (let ((sum 0)) - (declare (fixnum sum)) - (dolist (space-total v) - (incf sum (first (cdr space-total)))) - (summary-totals (cons sum v)))) + (maphash (lambda (k v) + (declare (ignore k)) + (let ((sum 0)) + (declare (fixnum sum)) + (dolist (space-total v) + (incf sum (first (cdr space-total)))) + (summary-totals (cons sum v)))) summary) (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces) @@ -316,7 +326,7 @@ (format t "~%~A:~% ~:D bytes, ~:D object~:P" name total-bytes total-objects) (dolist (space (spaces)) - (format t ", ~D% ~(~A~)" + (format t ", ~W% ~(~A~)" (round (* (cdr space) 100) total-bytes) (car space))) (format t ".~%") @@ -366,8 +376,8 @@ (let* ((spaces (if (eq count-spaces t) '(:static :dynamic :read-only) count-spaces)) - (totals (mapcar #'(lambda (space) - (cons space (type-breakdown space))) + (totals (mapcar (lambda (space) + (cons space (type-breakdown space))) spaces))) (dolist (space-total totals) @@ -388,17 +398,17 @@ (declare (fixnum code-words no-ops) (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)))) - (incf code-words words) - (dotimes (i words) - (when (zerop (sap-ref-32 sap (* i n-word-bytes))) - (incf no-ops)))))) + (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)))) + (incf code-words words) + (dotimes (i words) + (when (zerop (sap-ref-32 sap (* i n-word-bytes))) + (incf no-ops)))))) space) (format t @@ -417,55 +427,55 @@ (dolist (space (or spaces '(:read-only :static :dynamic))) (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)) - (incf non-descriptor-bytes (* inst-words n-word-bytes)) - (incf descriptor-words - (- (truncate size n-word-bytes) inst-words)))) - ((#.bignum-widetag - #.single-float-widetag - #.double-float-widetag - #.simple-string-widetag - #.simple-bit-vector-widetag - #.simple-array-unsigned-byte-2-widetag - #.simple-array-unsigned-byte-4-widetag - #.simple-array-unsigned-byte-8-widetag - #.simple-array-unsigned-byte-16-widetag - #.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 - #.simple-array-complex-single-float-widetag - #.simple-array-complex-double-float-widetag) - (incf non-descriptor-headers) - (incf non-descriptor-bytes (- size n-word-bytes))) - ((#.list-pointer-lowtag - #.instance-pointer-lowtag - #.ratio-widetag - #.complex-widetag - #.simple-array-widetag - #.simple-vector-widetag - #.complex-string-widetag - #.complex-bit-vector-widetag - #.complex-vector-widetag - #.complex-array-widetag - #.closure-header-widetag - #.funcallable-instance-header-widetag - #.value-cell-header-widetag - #.symbol-header-widetag - #.sap-widetag - #.weak-pointer-widetag - #.instance-header-widetag) - (incf descriptor-words (truncate size n-word-bytes))) - (t - (error "bogus type: ~D" type)))) + (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)) + (incf non-descriptor-bytes (* inst-words n-word-bytes)) + (incf descriptor-words + (- (truncate size n-word-bytes) inst-words)))) + ((#.bignum-widetag + #.single-float-widetag + #.double-float-widetag + #.simple-string-widetag + #.simple-bit-vector-widetag + #.simple-array-unsigned-byte-2-widetag + #.simple-array-unsigned-byte-4-widetag + #.simple-array-unsigned-byte-8-widetag + #.simple-array-unsigned-byte-16-widetag + #.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 + #.simple-array-complex-single-float-widetag + #.simple-array-complex-double-float-widetag) + (incf non-descriptor-headers) + (incf non-descriptor-bytes (- size n-word-bytes))) + ((#.list-pointer-lowtag + #.instance-pointer-lowtag + #.ratio-widetag + #.complex-widetag + #.simple-array-widetag + #.simple-vector-widetag + #.complex-string-widetag + #.complex-bit-vector-widetag + #.complex-vector-widetag + #.complex-array-widetag + #.closure-header-widetag + #.funcallable-instance-header-widetag + #.value-cell-header-widetag + #.symbol-header-widetag + #.sap-widetag + #.weak-pointer-widetag + #.instance-header-widetag) + (incf descriptor-words (truncate size n-word-bytes))) + (t + (error "bogus widetag: ~W" type)))) space)) (format t "~:D words allocated for descriptor objects.~%" descriptor-words) @@ -478,31 +488,31 @@ ;;; TOP-N types with largest usage. (defun instance-usage (space &key (top-n 15)) (declare (type spaces space) (type (or fixnum null) top-n)) - (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space) + (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space) (let ((totals (make-hash-table :test 'eq)) (total-objects 0) (total-bytes 0)) (declare (fixnum total-objects total-bytes)) (map-allocated-objects - #'(lambda (obj type size) - (declare (fixnum size) (optimize (speed 3) (safety 0))) - (when (eql type instance-header-widetag) - (incf total-objects) - (incf total-bytes size) - (let* ((class (layout-class (%instance-ref obj 0))) - (found (gethash class totals))) - (cond (found - (incf (the fixnum (car found))) - (incf (the fixnum (cdr found)) size)) - (t - (setf (gethash class totals) (cons 1 size))))))) + (lambda (obj type size) + (declare (fixnum size) (optimize (speed 3) (safety 0))) + (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))) + (cond (found + (incf (the fixnum (car found))) + (incf (the fixnum (cdr found)) size)) + (t + (setf (gethash classoid totals) (cons 1 size))))))) space) (collect ((totals-list)) - (maphash #'(lambda (class what) - (totals-list (cons (prin1-to-string - (class-proper-name class)) - what))) + (maphash (lambda (classoid what) + (totals-list (cons (prin1-to-string + (classoid-proper-name classoid)) + what))) totals) (let ((sorted (sort (totals-list) #'> :key #'cddr)) (printed-bytes 0) @@ -515,13 +525,13 @@ (objects (cadr what))) (incf printed-bytes bytes) (incf printed-objects objects) - (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what) + (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what) bytes objects))) (let ((residual-objects (- total-objects printed-objects)) (residual-bytes (- total-bytes printed-bytes))) (unless (zerop residual-objects) - (format t " Other types: ~:D bytes, ~D object~:P.~%" + (format t " Other types: ~:D bytes, ~:D object~:P.~%" residual-bytes residual-objects)))) (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%" @@ -537,22 +547,22 @@ (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)))) + (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)))) + (format t "~:D bytes at #X~X~%" total-bytes start-addr)))) (values)) ;;;; PRINT-ALLOCATED-OBJECTS @@ -581,58 +591,58 @@ (note-conses (car x)) (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 - (> count-so-far count) - (> pages-so-far pages)) - (return-from print-allocated-objects (values))) - - (unless count - (let ((this-page (* (the (values (unsigned-byte 32) t) - (truncate addr pagesize)) - pagesize))) - (declare (type (unsigned-byte 32) this-page)) - (when (/= this-page last-page) - (when (< pages-so-far pages) - ;; FIXME: What is this? (ERROR "Argh..")? or - ;; a warning? or code that can be removed - ;; once the system is stable? or what? - (format stream "~2&**** Page ~D, address ~X:~%" - pages-so-far addr)) - (setq last-page this-page) - (incf pages-so-far)))) - - (when (and (or (not type) (eql obj-type type)) - (or (not smaller) (<= size smaller)) - (or (not larger) (>= size larger))) - (incf count-so-far) - (case type - (#.code-header-widetag - (let ((dinfo (%code-debug-info obj))) - (format stream "~&Code object: ~S~%" - (if dinfo - (sb!c::compiled-debug-info-name dinfo) - "No debug info.")))) - (#.symbol-header-widetag - (format stream "~&~S~%" obj)) - (#.list-pointer-lowtag - (unless (gethash obj printed-conses) - (note-conses obj) - (let ((*print-circle* t) - (*print-level* 5) - (*print-length* 10)) - (format stream "~&~S~%" obj)))) - (t - (fresh-line stream) - (let ((str (write-to-string obj :level 5 :length 10 - :pretty nil))) - (unless (eql type instance-header-widetag) - (format stream "~S: " (type-of obj))) - (format stream "~A~%" - (subseq str 0 (min (length str) 60)))))))))) + (lambda (obj obj-type size) + (declare (optimize (safety 0))) + (let ((addr (get-lisp-obj-address obj))) + (when (>= addr start) + (when (if count + (> count-so-far count) + (> pages-so-far pages)) + (return-from print-allocated-objects (values))) + + (unless count + (let ((this-page (* (the (values (unsigned-byte 32) t) + (truncate addr pagesize)) + pagesize))) + (declare (type (unsigned-byte 32) this-page)) + (when (/= this-page last-page) + (when (< pages-so-far pages) + ;; FIXME: What is this? (ERROR "Argh..")? or + ;; a warning? or code that can be removed + ;; once the system is stable? or what? + (format stream "~2&**** Page ~W, address ~X:~%" + pages-so-far addr)) + (setq last-page this-page) + (incf pages-so-far)))) + + (when (and (or (not type) (eql obj-type type)) + (or (not smaller) (<= size smaller)) + (or (not larger) (>= size larger))) + (incf count-so-far) + (case type + (#.code-header-widetag + (let ((dinfo (%code-debug-info obj))) + (format stream "~&Code object: ~S~%" + (if dinfo + (sb!c::compiled-debug-info-name dinfo) + "No debug info.")))) + (#.symbol-header-widetag + (format stream "~&~S~%" obj)) + (#.list-pointer-lowtag + (unless (gethash obj printed-conses) + (note-conses obj) + (let ((*print-circle* t) + (*print-level* 5) + (*print-length* 10)) + (format stream "~&~S~%" obj)))) + (t + (fresh-line stream) + (let ((str (write-to-string obj :level 5 :length 10 + :pretty nil))) + (unless (eql type instance-header-widetag) + (format stream "~S: " (type-of obj))) + (format stream "~A~%" + (subseq str 0 (min (length str) 60)))))))))) space)))) (values)) @@ -656,15 +666,15 @@ (collect ((counted 0 1+)) (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)) - (or (not test) (funcall test obj))) - (setq res (maybe-cons space obj res)) - (when (and count (>= (counted) count)) - (return-from list-allocated-objects res)))) + (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)) + (or (not test) (funcall test obj))) + (setq res (maybe-cons space obj res)) + (when (and count (>= (counted) count)) + (return-from list-allocated-objects res)))) space) res))) @@ -675,27 +685,27 @@ (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))))) + (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))