X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=d1813360da4067aa8f76bb309670445e35063334;hb=6a0601ab48635465ad3400c290e5cfbca28e5367;hp=c957c8d0c5edd3240c93d01528c9722b9b622f3f;hpb=70769503c505c22bddef3bc7885b91b9d503607f;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index c957c8d..d181336 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -88,8 +88,10 @@ (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) @@ -179,11 +181,12 @@ (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)) @@ -193,34 +196,33 @@ (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 @@ -231,9 +233,9 @@ (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)) @@ -265,7 +267,7 @@ ;; 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 @@ -275,8 +277,7 @@ ;; 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)) @@ -296,13 +297,13 @@ (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))) @@ -310,7 +311,7 @@ (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)))) @@ -319,7 +320,7 @@ (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 @@ -340,10 +341,14 @@ (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)))))))))))))) ;;;; MEMORY-USAGE @@ -351,11 +356,11 @@ ;;; 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) @@ -395,7 +400,7 @@ (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)))) @@ -404,13 +409,13 @@ (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))) @@ -442,8 +447,8 @@ 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.~%" @@ -494,12 +499,13 @@ (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))) @@ -523,11 +529,11 @@ (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)))) @@ -545,7 +551,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 @@ -571,7 +577,7 @@ #.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)) @@ -590,15 +596,17 @@ (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)) @@ -615,7 +623,7 @@ (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)) @@ -664,7 +672,6 @@ (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 @@ -745,7 +752,6 @@ (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)) @@ -765,7 +771,7 @@ (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) @@ -792,7 +798,8 @@ (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)))