;;;; files for more information.
(in-package "SB!VM")
-
-(file-comment
- "$Header$")
\f
;;;; type format database
(kind (required-argument)
: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)
: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)))
+(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)))
(setf (svref *meta-room-info* (symbol-value name))
: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-widetag
:kind :string
:length 0))
-(setf (svref *meta-room-info* code-header-type)
+(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))
\f
;;;; MAP-ALLOCATED-OBJECTS
-(declaim (type fixnum *static-space-free-pointer*
- *read-only-space-free-pointer* ))
+;;; Since they're represented as counts of words, we should never
+;;; need bignums to represent these:
+(declaim (type fixnum
+ *static-space-free-pointer*
+ *read-only-space-free-pointer*))
(defun space-bounds (space)
(declare (type spaces space))
(ecase space
(:static
- (values (int-sap (static-space-start))
+ (values (int-sap static-space-start)
(int-sap (* *static-space-free-pointer* word-bytes))))
(:read-only
- (values (int-sap (read-only-space-start))
+ (values (int-sap read-only-space-start)
(int-sap (* *read-only-space-free-pointer* word-bytes))))
(:dynamic
- (values (int-sap (current-dynamic-space-start))
+ (values (int-sap dynamic-space-start)
(dynamic-space-free-pointer)))))
;;; Return the total number of bytes used in SPACE.
(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)))
(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)
- function-pointer-type)))
+ fun-pointer-lowtag)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
- (funcall fun obj header-type size)
+ (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))))
(declare (fixnum size))
- (funcall fun obj header-type size)
- (assert (zerop (logand size lowtag-mask)))
+ (funcall fun obj header-widetag size)
+ (aver (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000) (break "implausible size, prev ~S" prev))
#+nil
(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
- (assert (or (eql (room-info-length info)
+ (aver (or (eql (room-info-length info)
(1+ (get-header-data obj)))
(floatp obj)))
(round-to-dualword
(* (the fixnum (%code-code-size obj))
word-bytes)))))))
(declare (fixnum size))
- (funcall fun obj header-type size)
- (assert (zerop (logand size lowtag-mask)))
+ (funcall fun obj header-widetag size)
+ (aver (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000)
(break "Implausible size, prev ~S" prev))
(setq prev current)
(setq current (sap+ current size))))))
(unless (sap< current end)
- (assert (sap= current end))
+ (aver (sap= current end))
(return)))
#+nil
(format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
total-bytes total-objects (car space-total))))
+;;; Print information about the heap memory in use. PRINT-SPACES is a
+;;; list of the spaces to print detailed information for.
+;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
+;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
+;;; PRINT-SUMMARY is true, then summary information will be printed.
+;;; The defaults print only summary information for dynamic space. If
+;;; true, CUTOFF is a fraction of the usage in a report below which
+;;; types will be combined as OTHER.
(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
(print-summary t) cutoff)
- #!+sb-doc
- "Print out information about the heap memory in use. :Print-Spaces is a list
- of the spaces to print detailed information for. :Count-Spaces is a list of
- the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
- and :Read-Only.) If :Print-Summary is true, then summary information will be
- printed. The defaults print only summary information for dynamic space.
- If true, Cutoff is a fraction of the usage in a report below which types will
- be combined as OTHER."
(declare (type (or single-float null) cutoff))
(let* ((spaces (if (eq count-spaces t)
'(:static :dynamic :read-only)
(values))
\f
+;;; Print info about how much code and no-ops there are in SPACE.
(defun count-no-ops (space)
- #!+sb-doc
- "Print info about how much code and no-ops there are in Space."
(declare (type spaces space))
(let ((code-words 0)
(no-ops 0)
(map-allocated-objects
#'(lambda (obj type size)
(declare (fixnum size) (optimize (safety 0)))
- (when (eql type code-header-type)
+ (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
#'(lambda (obj type size)
(declare (fixnum size) (optimize (safety 0)))
(case type
- (#.code-header-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 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)
+ ((#.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 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)
+ ((#.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 word-bytes)))
(t
(error "Bogus type: ~D" type))))
non-descriptor-bytes non-descriptor-headers)
(values)))
\f
+;;; Print a breakdown by instance type of all the instances allocated
+;;; in SPACE. If TOP-N is true, print only information for the the
+;;; TOP-N types with largest usage.
(defun instance-usage (space &key (top-n 15))
(declare (type spaces space) (type (or fixnum null) top-n))
- #!+sb-doc
- "Print a breakdown by instance type of all the instances allocated in
- Space. If TOP-N is true, print only information for the the TOP-N types with
- largest usage."
(format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
(let ((totals (make-hash-table :test 'eq))
(total-objects 0)
(map-allocated-objects
#'(lambda (obj type size)
(declare (fixnum size) (optimize (speed 3) (safety 0)))
- (when (eql type instance-header-type)
+ (when (eql type instance-header-widetag)
(incf total-objects)
(incf total-bytes size)
(let* ((class (layout-class (%instance-ref obj 0)))
(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.~%"
(return-from print-allocated-objects (values)))
(unless count
- (let ((this-page (* (the (unsigned-byte 32)
- (truncate addr pagesize))
+ (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)
(or (not larger) (>= size larger)))
(incf count-so-far)
(case type
- (#.code-header-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-type
+ (#.symbol-header-widetag
(format stream "~&~S~%" obj))
- (#.list-pointer-type
+ (#.list-pointer-lowtag
(unless (gethash obj printed-conses)
(note-conses obj)
(let ((*print-circle* t)
(fresh-line stream)
(let ((str (write-to-string obj :level 5 :length 10
:pretty nil)))
- (unless (eql type instance-header-type)
+ (unless (eql type instance-header-widetag)
(format stream "~S: " (type-of obj)))
(format stream "~A~%"
(subseq str 0 (min (length str) 60))))))))))
projects / sbcl.git / blobdiff