(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)
(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))
(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 nil
+ (define-alien-type (struct page)
(struct page
- (flags unsigned-int)
- (gen int)
- (bytes-used int)
- (start long)))
+ (start long)
+ ;; 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-page-size
+ '(unsigned-byte 16))
+ 16
+ 32)))
+ (flags (unsigned 8))
+ (gen (signed 8))))
(declaim (inline find-page-index))
(define-alien-routine "find_page_index" long (index long))
- (define-alien-variable "page_table"
- (array (struct page)
- #.(truncate (- dynamic-space-end
- dynamic-space-start)
- sb!vm:gencgc-page-size))))
+ (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
(without-gcing
(multiple-value-bind (start end) (space-bounds space)
(declare (type system-area-pointer start end))
- (declare (optimize (speed 3) (safety 0)))
+ (declare (optimize (speed 3)))
(let ((current start)
- (skip-tests-until-addr 0))
+ #!+gencgc (skip-tests-until-addr 0))
(labels ((maybe-finish-mapping ()
(unless (sap< current end)
(aver (sap= current end))
;; bitfields?
(let ((alloc-flag (ldb (byte 3 2)
(slot page 'flags)))
- (bytes-used (slot page 'bytes-used)))
+ (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
;; Don't bother testing again until we
;; get past that allocation offset
(setf skip-tests-until-addr
- (+ (logandc2 addr page-mask)
- (the fixnum bytes-used)))
+ (+ (logandc2 addr page-mask) bytes-used))
;; And then continue with the scheduled
;; mapping
(return-from maybe-skip-page))
(eq (room-info-kind info) :lowtag))
(let ((size (* cons-size n-word-bytes)))
(funcall fun
- (make-lisp-obj (logior (sap-int current)
+ (%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)
+ (let* ((obj (%make-lisp-obj (logior (sap-int current)
fun-pointer-lowtag)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
(funcall fun obj header-widetag size)
(setq current (sap+ current size))))
((eq (room-info-kind info) :instance)
- (let* ((obj (make-lisp-obj
+ (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)))
(setq current (sap+ current size))))
(t
- (let* ((obj (make-lisp-obj
+ (let* ((obj (%make-lisp-obj
(logior (sap-int current) other-pointer-lowtag)))
(size (ecase (room-info-kind info)
(:fixed
(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)))
- (setq current (sap+ current size))))))))))))
+ (macrolet ((frob ()
+ `(progn
+ (aver (zerop (logand size lowtag-mask)))
+ (setq current (sap+ current size)))))
+ (etypecase size
+ (fixnum (frob))
+ (word (frob))))))))))))))
\f
;;;; 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)
(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))))
(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)))
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.~%"
(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))))
+ (%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)))
(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))))
#.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
#.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))
(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))
(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))
(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
(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))
(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)
(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)))
projects / sbcl.git / blobdiff