(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))
(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 (struct page)
+ (struct page
+ (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" (* (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
(defun map-allocated-objects (fun space)
(declare (type function fun) (type spaces space))
(without-gcing
- (multiple-value-bind (start end) (space-bounds space)
- (declare (type system-area-pointer start end))
- (declare (optimize (speed 3) (safety 0)))
- (let ((current start)
- #+nil
- (prev nil))
- (loop
- (let* ((header (sap-ref-word current 0))
- (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 n-word-bytes)))
- (funcall fun
- (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)
- fun-pointer-lowtag)))
- (size (round-to-dualword
- (* (the fixnum (1+ (get-closure-length obj)))
- 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-lowtag)))
- (size (round-to-dualword
- (* (+ (%instance-length obj) 1) n-word-bytes))))
- (declare (fixnum size))
- (funcall fun obj header-widetag size)
- (aver (zerop (logand size lowtag-mask)))
- #+nil
- (when (> size 200000) (break "implausible size, prev ~S" prev))
- #+nil
- (setq prev current)
- (setq current (sap+ current size))))
- (t
- (let* ((obj (make-lisp-obj
- (logior (sap-int current) other-pointer-lowtag)))
- (size (ecase (room-info-kind info)
- (:fixed
- (aver (or (eql (room-info-length info)
+ (multiple-value-bind (start end) (space-bounds space)
+ (declare (type system-area-pointer start end))
+ (declare (optimize (speed 3)))
+ (let ((current start)
+ #!+gencgc (skip-tests-until-addr 0))
+ (labels ((maybe-finish-mapping ()
+ (unless (sap< current end)
+ (aver (sap= current end))
+ (return-from map-allocated-objects)))
+ ;; GENCGC doesn't allocate linearly, which means that the
+ ;; dynamic space can contain large blocks zeros that get
+ ;; accounted as conses in ROOM (and slow down other
+ ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
+ ;; check the GC page structure for the current address.
+ ;; If the page is free or the address is beyond the page-
+ ;; internal allocation offset (bytes-used) skip to the
+ ;; next page immediately.
+ (maybe-skip-page ()
+ #!+gencgc
+ (when (eq space :dynamic)
+ (loop with page-mask = #.(1- sb!vm:gencgc-page-size)
+ for addr of-type sb!vm:word = (sap-int current)
+ while (>= addr skip-tests-until-addr)
+ do
+ ;; For some reason binding PAGE with LET
+ ;; conses like mad (but gives no compiler notes...)
+ ;; Work around the problem with SYMBOL-MACROLET
+ ;; instead of trying to figure out the real
+ ;; issue. -- JES, 2005-05-17
+ (symbol-macrolet
+ ((page (deref page-table
+ (find-page-index addr))))
+ ;; Don't we have any nicer way to access C struct
+ ;; bitfields?
+ (let ((alloc-flag (ldb (byte 3 2)
+ (slot page 'flags)))
+ (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
+ (when (and (not (zerop alloc-flag))
+ (<= (logand page-mask addr)
+ bytes-used))
+ ;; 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)))
+ ;; And then continue with the scheduled
+ ;; mapping
+ (return-from maybe-skip-page))
+ ;; Move CURRENT to start of next page
+ (setf current (int-sap (+ (logandc2 addr page-mask)
+ sb!vm:gencgc-page-size)))
+ (maybe-finish-mapping)))))))
+ (declare (inline maybe-finish-mapping maybe-skip-page))
+ (loop
+ (maybe-finish-mapping)
+ (maybe-skip-page)
+ (let* ((header (sap-ref-word current 0))
+ (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 n-word-bytes)))
+ (funcall fun
+ (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)
+ fun-pointer-lowtag)))
+ (size (round-to-dualword
+ (* (the fixnum (1+ (get-closure-length obj)))
+ 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-lowtag)))
+ (size (round-to-dualword
+ (* (+ (%instance-length obj) 1) n-word-bytes))))
+ (declare (fixnum size))
+ (funcall fun obj header-widetag size)
+ (aver (zerop (logand size lowtag-mask)))
+ (setq current (sap+ current size))))
+ (t
+ (let* ((obj (make-lisp-obj
+ (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)
- (simple-array-nil-p obj)))
- (round-to-dualword
- (* (room-info-length info) n-word-bytes)))
- ((:vector :string)
- (vector-total-size obj info))
- (:header
- (round-to-dualword
- (* (1+ (get-header-data obj)) n-word-bytes)))
- (:code
- (+ (the fixnum
- (* (get-header-data obj) n-word-bytes))
- (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)))
- #+nil
- (when (> size 200000)
- (break "Implausible size, prev ~S" prev))
- #+nil
- (setq prev current)
- (setq current (sap+ current size))))))
- (unless (sap< current end)
- (aver (sap= current end))
- (return)))
-
- #+nil
- prev))))
+ (floatp obj)
+ (simple-array-nil-p obj)))
+ (round-to-dualword
+ (* (room-info-length info) n-word-bytes)))
+ ((:vector :string)
+ (vector-total-size obj info))
+ (:header
+ (round-to-dualword
+ (* (1+ (get-header-data obj)) n-word-bytes)))
+ (:code
+ (+ (the fixnum
+ (* (get-header-data obj) n-word-bytes))
+ (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))))))))))))
+
\f
;;;; MEMORY-USAGE
(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))
+ (declare (fixnum size) (optimize (speed 3)) (ignore obj))
(incf (aref sizes type) size)
(incf (aref counts type)))
space)
(type unsigned-byte total-bytes))
(map-allocated-objects
(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
+ (declare (fixnum size))
(when (eql type code-header-widetag)
(incf total-bytes size)
(let ((words (truly-the fixnum (%code-code-size obj)))
(declare (inline map-allocated-objects))
(map-allocated-objects
(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
+ (declare (fixnum size))
(case type
(#.code-header-widetag
(let ((inst-words (truly-the fixnum (%code-code-size obj))))
(declare (fixnum total-objects total-bytes))
(map-allocated-objects
(lambda (obj type size)
- (declare (fixnum size) (optimize (speed 3) (safety 0)))
+ (declare (fixnum size) (optimize (speed 3)))
(when (eql type instance-header-widetag)
(incf total-objects)
(incf total-bytes size)
(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)
projects / sbcl.git / blobdiff