;;;; files for more information.
(in-package "SB!VM")
+
+(declaim (special sb!vm:*read-only-space-free-pointer*
+ sb!vm:*static-space-free-pointer*))
\f
;;;; type format database
(size (primitive-object-size obj)))
(cond
((not lowtag))
- (;; KLUDGE described in dan_b message "Another one for the
- ;; collection [bug 108]" (sbcl-devel 2004-01-22)
- ;;
- ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes
- ;; debugger invoked on a SB-INT:BUG in thread 5911:
- ;; failed AVER: "(SAP= CURRENT END)"
- ;; [WHN: Similar things happened on one but not the other of my
- ;; machines when I just run ROOM a lot in a loop.]
- ;;
- ;; This appears to be due to my [DB] abuse of the primitive
- ;; object macros to define a thread object that shares a lowtag
- ;; with fixnums and has no widetag: it looks like the code that
- ;; generates *META-ROOM-INFO* infers from this that even fixnums
- ;; are thread-sized - probably undesirable.
- ;;
- ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
- ;; nature of a workaround than a really good fix. I'm not sure
- ;; what a really good fix is: I /think/ it's probably to remove
- ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
- ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
- ;; for assembly source in the runtime/genesis/*.h files.
- (eql name 'thread))
((not widetag)
(let ((info (make-room-info :name name
:kind :lowtag))
(simple-array-unsigned-byte-16-widetag . 1)
(simple-array-unsigned-byte-31-widetag . 2)
(simple-array-unsigned-byte-32-widetag . 2)
- (simple-array-unsigned-byte-60-widetag . 3)
+ (simple-array-unsigned-fixnum-widetag . #.sb!vm:word-shift)
(simple-array-unsigned-byte-63-widetag . 3)
(simple-array-unsigned-byte-64-widetag . 3)
(simple-array-signed-byte-8-widetag . 0)
(simple-array-signed-byte-16-widetag . 1)
- (simple-array-unsigned-byte-29-widetag . 2)
- (simple-array-signed-byte-30-widetag . 2)
+ (simple-array-fixnum-widetag . #.sb!vm:word-shift)
(simple-array-signed-byte-32-widetag . 2)
- (simple-array-signed-byte-61-widetag . 3)
(simple-array-signed-byte-64-widetag . 3)
(simple-array-single-float-widetag . 2)
(simple-array-double-float-widetag . 3)
(make-room-info :name 'instance
:kind :instance))
+(setf (svref *meta-room-info* funcallable-instance-header-widetag)
+ (make-room-info :name 'funcallable-instance
+ :kind :closure))
+
) ; EVAL-WHEN
(defparameter *room-info* '#.*meta-room-info*)
(ecase space
(:static
(values (int-sap static-space-start)
- (int-sap (* *static-space-free-pointer* n-word-bytes))))
+ (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
(:read-only
(values (int-sap read-only-space-start)
- (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
+ (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
(:dynamic
(values (int-sap (current-dynamic-space-start))
(dynamic-space-free-pointer)))))
;;; 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))
;; will be a short. On platforms with larger ones, it'll
;; be an int.
(bytes-used (unsigned
- #.(if (typep sb!vm:gencgc-page-size
+ #.(if (typep sb!vm:gencgc-card-bytes
'(unsigned-byte 16))
16
32)))
;;; 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
-;;; bytes, including any header and padding.
+;;; bytes, including any header and padding. CAREFUL makes
+;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
+;;; is intended for slightly more demanding uses of heap groveling
+;;; then ROOM.
#!-sb-fluid (declaim (maybe-inline map-allocated-objects))
-(defun map-allocated-objects (fun space)
+(defun map-allocated-objects (fun space &optional careful)
(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)))
- (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) 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)))
- (setq current (sap+ current size))))))))))))
+ (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
+ (flet ((make-obj (tagged-address)
+ (if careful
+ (make-lisp-obj tagged-address nil)
+ (values (%make-lisp-obj tagged-address) t))))
+ ;; Inlining MAKE-OBJ reduces consing on platforms where dynamic
+ ;; space extends past fixnum range.
+ (declare (inline make-obj))
+ (without-gcing
+ (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-card-bytes)
+ 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) 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-card-bytes)))
+ (maybe-finish-mapping))))))
+ (maybe-map (obj obj-tag n-obj-bytes &optional (ok t))
+ (let ((next (typecase n-obj-bytes
+ (fixnum (sap+ current n-obj-bytes))
+ (integer (sap+ current n-obj-bytes)))))
+ ;; If this object would take us past END, it must
+ ;; be either bogus, or it has been allocated after
+ ;; the call to M-A-O.
+ (cond ((and ok next (sap<= next end))
+ (funcall fun obj obj-tag n-obj-bytes)
+ (setf current next))
+ (t
+ (setf current (sap+ current n-word-bytes)))))))
+ (declare (inline maybe-finish-mapping maybe-skip-page maybe-map))
+ (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))
+ (multiple-value-bind (obj ok)
+ (make-obj (logior (sap-int current) list-pointer-lowtag))
+ (maybe-map obj
+ list-pointer-lowtag
+ (* cons-size n-word-bytes)
+ ok)))
+ ((eq (room-info-kind info) :closure)
+ (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))))
+ (maybe-map obj header-widetag 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))))
+ (aver (zerop (logand size lowtag-mask)))
+ (maybe-map obj header-widetag size)))
+ (t
+ (multiple-value-bind (obj ok)
+ (make-obj (logior (sap-int current) other-pointer-lowtag))
+ (let ((size (when ok
+ (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))))))))
+ (macrolet ((frob ()
+ '(progn
+ (when size (aver (zerop (logand size lowtag-mask))))
+ (maybe-map obj header-widetag size))))
+ (typecase size
+ (fixnum (frob))
+ (word (frob))
+ (null (frob))))))))))))))))
\f
;;;; MEMORY-USAGE
(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)) (ignore obj))
+ (declare (word 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))
(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))))
+ (sap (%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))
(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-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))
(declare (unsigned-byte total-objects total-bytes))
(map-allocated-objects
(lambda (obj type size)
- (declare (fixnum size) (optimize (speed 3)))
+ (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))
space)
res)))
+;;; Calls FUNCTION with all object that have (possibly conservative)
+;;; references to them on current stack.
+(defun map-stack-references (function)
+ (let ((end
+ (sb!di::descriptor-sap
+ #!+stack-grows-downward-not-upward *control-stack-end*
+ #!-stack-grows-downward-not-upward *control-stack-start*))
+ (sp (current-sp))
+ (seen nil))
+ (loop until #!+stack-grows-downward-not-upward (sap> sp end)
+ #!-stack-grows-downward-not-upward (sap< sp end)
+ do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
+ (when (and ok (typep obj '(not (or fixnum character))))
+ (unless (member obj seen :test #'eq)
+ (funcall function obj)
+ (push obj seen))))
+ (setf sp
+ #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
+ #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
+
(defun map-referencing-objects (fun space object)
(declare (type spaces space) (inline map-allocated-objects))
(unless *ignore-after*
projects / sbcl.git / blobdiff