X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=4dbefe7f41dd2eb4107f99f6dbc465325296ef7d;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=ab96ff241bdae7281aed4d19469d7e39522fca9f;hpb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index ab96ff2..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) @@ -29,14 +29,14 @@ (defvar *meta-room-info* (make-array 256 :initial-element nil)) (dolist (obj *primitive-objects*) - (let ((header (primitive-object-header obj)) + (let ((widetag (primitive-object-widetag obj)) (lowtag (primitive-object-lowtag obj)) (name (primitive-object-name obj)) - (variable (primitive-object-variable-length obj)) + (variable (primitive-object-variable-length-p obj)) (size (primitive-object-size obj))) (cond ((not lowtag)) - ((not header) + ((not widetag) (let ((info (make-room-info :name name :kind :lowtag)) (lowtag (symbol-value lowtag))) @@ -45,62 +45,71 @@ (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info)))) (variable) (t - (setf (svref *meta-room-info* (symbol-value header)) + (setf (svref *meta-room-info* (symbol-value widetag)) (make-room-info :name name :kind :fixed :length size)))))) -(dolist (code (list complex-string-type simple-array-type - complex-bit-vector-type complex-vector-type - complex-array-type)) +(dolist (code (list complex-string-widetag simple-array-widetag + complex-bit-vector-widetag complex-vector-widetag + complex-array-widetag)) (setf (svref *meta-room-info* code) (make-room-info :name 'array-header :kind :header))) -(setf (svref *meta-room-info* bignum-type) +(setf (svref *meta-room-info* bignum-widetag) (make-room-info :name 'bignum :kind :header)) -(setf (svref *meta-room-info* closure-header-type) +(setf (svref *meta-room-info* closure-header-widetag) (make-room-info :name 'closure :kind :closure)) -(dolist (stuff '((simple-bit-vector-type . -3) - (simple-vector-type . 2) - (simple-array-unsigned-byte-2-type . -2) - (simple-array-unsigned-byte-4-type . -1) - (simple-array-unsigned-byte-8-type . 0) - (simple-array-unsigned-byte-16-type . 1) - (simple-array-unsigned-byte-32-type . 2) - (simple-array-signed-byte-8-type . 0) - (simple-array-signed-byte-16-type . 1) - (simple-array-signed-byte-30-type . 2) - (simple-array-signed-byte-32-type . 2) - (simple-array-single-float-type . 2) - (simple-array-double-float-type . 3) - (simple-array-complex-single-float-type . 3) - (simple-array-complex-double-float-type . 4))) - (let ((name (car stuff)) - (size (cdr stuff))) +(dolist (stuff '((simple-bit-vector-widetag . -3) + (simple-vector-widetag . 2) + (simple-array-unsigned-byte-2-widetag . -2) + (simple-array-unsigned-byte-4-widetag . -1) + (simple-array-unsigned-byte-8-widetag . 0) + (simple-array-unsigned-byte-16-widetag . 1) + (simple-array-unsigned-byte-32-widetag . 2) + (simple-array-signed-byte-8-widetag . 0) + (simple-array-signed-byte-16-widetag . 1) + (simple-array-signed-byte-30-widetag . 2) + (simple-array-signed-byte-32-widetag . 2) + (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))) (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-type) - (make-room-info :name 'simple-string-type +(setf (svref *meta-room-info* simple-string-widetag) + (make-room-info :name 'simple-string :kind :string :length 0)) -(setf (svref *meta-room-info* code-header-type) +(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)) -(setf (svref *meta-room-info* instance-header-type) +(setf (svref *meta-room-info* instance-header-widetag) (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)) @@ -118,10 +127,10 @@ (ecase space (:static (values (int-sap static-space-start) - (int-sap (* *static-space-free-pointer* word-bytes)))) + (int-sap (* *static-space-free-pointer* n-word-bytes)))) (:read-only (values (int-sap read-only-space-start) - (int-sap (* *read-only-space-free-pointer* word-bytes)))) + (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) (:dynamic (values (int-sap dynamic-space-start) (dynamic-space-free-pointer))))) @@ -147,7 +156,7 @@ (:string 1))))) (declare (type (integer -3 3) shift)) (round-to-dualword - (+ (* vector-data-offset word-bytes) + (+ (* vector-data-offset n-word-bytes) (the fixnum (if (minusp shift) (ash (the fixnum @@ -171,33 +180,33 @@ (prev nil)) (loop (let* ((header (sap-ref-32 current 0)) - (header-type (logand header #xFF)) - (info (svref *room-info* header-type))) + (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 word-bytes))) + (let ((size (* cons-size n-word-bytes))) (funcall fun (make-lisp-obj (logior (sap-int current) - list-pointer-type)) - list-pointer-type + list-pointer-lowtag)) + list-pointer-lowtag size) (setq current (sap+ current size)))) - ((eql header-type closure-header-type) + ((eql header-widetag closure-header-widetag) (let* ((obj (make-lisp-obj (logior (sap-int current) - fun-pointer-type))) + fun-pointer-lowtag))) (size (round-to-dualword (* (the fixnum (1+ (get-closure-length obj))) - word-bytes)))) - (funcall fun obj header-type size) + 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-type))) + (logior (sap-int current) instance-pointer-lowtag))) (size (round-to-dualword - (* (+ (%instance-length obj) 1) word-bytes)))) + (* (+ (%instance-length obj) 1) n-word-bytes)))) (declare (fixnum size)) - (funcall fun obj header-type size) + (funcall fun obj header-widetag size) (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) (break "implausible size, prev ~S" prev)) @@ -206,27 +215,28 @@ (setq current (sap+ current size)))) (t (let* ((obj (make-lisp-obj - (logior (sap-int current) other-pointer-type))) + (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))) + (floatp obj) + (simple-array-nil-p obj))) (round-to-dualword - (* (room-info-length info) word-bytes))) + (* (room-info-length info) n-word-bytes))) ((:vector :string) (vector-total-size obj info)) (:header (round-to-dualword - (* (1+ (get-header-data obj)) word-bytes))) + (* (1+ (get-header-data obj)) n-word-bytes))) (:code (+ (the fixnum - (* (get-header-data obj) word-bytes)) + (* (get-header-data obj) n-word-bytes)) (round-to-dualword (* (the fixnum (%code-code-size obj)) - word-bytes))))))) + n-word-bytes))))))) (declare (fixnum size)) - (funcall fun obj header-type size) + (funcall fun obj header-widetag size) (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) @@ -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-type) - (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 sb!vm: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-type - (let ((inst-words (truly-the fixnum (%code-code-size obj)))) - (declare (type fixnum inst-words)) - (incf non-descriptor-bytes (* inst-words word-bytes)) - (incf descriptor-words - (- (truncate size word-bytes) inst-words)))) - ((#.bignum-type - #.single-float-type - #.double-float-type - #.simple-string-type - #.simple-bit-vector-type - #.simple-array-unsigned-byte-2-type - #.simple-array-unsigned-byte-4-type - #.simple-array-unsigned-byte-8-type - #.simple-array-unsigned-byte-16-type - #.simple-array-unsigned-byte-32-type - #.simple-array-signed-byte-8-type - #.simple-array-signed-byte-16-type - #.simple-array-signed-byte-30-type - #.simple-array-signed-byte-32-type - #.simple-array-single-float-type - #.simple-array-double-float-type - #.simple-array-complex-single-float-type - #.simple-array-complex-double-float-type) - (incf non-descriptor-headers) - (incf non-descriptor-bytes (- size word-bytes))) - ((#.list-pointer-type - #.instance-pointer-type - #.ratio-type - #.complex-type - #.simple-array-type - #.simple-vector-type - #.complex-string-type - #.complex-bit-vector-type - #.complex-vector-type - #.complex-array-type - #.closure-header-type - #.funcallable-instance-header-type - #.value-cell-header-type - #.symbol-header-type - #.sap-type - #.weak-pointer-type - #.instance-header-type) - (incf descriptor-words (truncate size 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-type) - (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 @@ -560,9 +570,9 @@ (defun print-allocated-objects (space &key (percent 0) (pages 5) type larger smaller count (stream *standard-output*)) - (declare (type (integer 0 99) percent) (type sb!c::index pages) + (declare (type (integer 0 99) percent) (type index pages) (type stream stream) (type spaces space) - (type (or sb!c::index null) type larger smaller count)) + (type (or index null) type larger smaller count)) (multiple-value-bind (start-sap end-sap) (space-bounds space) (let* ((space-start (sap-int start-sap)) (space-end (sap-int end-sap)) @@ -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-type - (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-type - (format stream "~&~S~%" obj)) - (#.list-pointer-type - (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-type) - (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)) @@ -649,22 +659,22 @@ (defun list-allocated-objects (space &key type larger smaller count test) (declare (type spaces space) - (type (or sb!c::index null) larger smaller type count) + (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))) (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))