Forked from
cmucl / cmucl
1520 commits behind the upstream repository.
-
Raymond Toy authored
src/compiler/generic/objdef.lisp:: src/compiler/generic/utils.lisp:; src/compiler/generic/vm-macs.lisp:: src/compiler/sparc/c-callback.lisp:: src/compiler/sparc/parms.lisp:: When export lost its compile-time effects and became a normal function, the exports in many files no longer took affect while compiling the file. This change makes the compile-time effects happen as before in selected files. With this change, the sparc port can be cross-compiled from x86 again. src/tools/cross-scripts/cross-x86-sparc.lisp:: Need to frob CHAR-BYTES, which is needed by BYTE-BASH-COPY. .
Raymond Toy authoredsrc/compiler/generic/objdef.lisp:: src/compiler/generic/utils.lisp:; src/compiler/generic/vm-macs.lisp:: src/compiler/sparc/c-callback.lisp:: src/compiler/sparc/parms.lisp:: When export lost its compile-time effects and became a normal function, the exports in many files no longer took affect while compiling the file. This change makes the compile-time effects happen as before in selected files. With this change, the sparc port can be cross-compiled from x86 again. src/tools/cross-scripts/cross-x86-sparc.lisp:: Need to frob CHAR-BYTES, which is needed by BYTE-BASH-COPY. .
room.lisp 38.22 KiB
;;; -*- Mode: Lisp; Package: VM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: src/code/room.lisp $")
;;;
;;; **********************************************************************
;;;
;;; Heap grovelling memory usage stuff.
;;;
(in-package "VM")
(use-package "SYSTEM")
(intl:textdomain "cmucl")
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
instance-usage find-holes print-allocated-objects
code-breakdown uninterned-symbol-count
list-allocated-objects))
)
(in-package "LISP")
(import '(
dynamic-0-space-start dynamic-1-space-start read-only-space-start
static-space-start current-dynamic-space-start
*static-space-free-pointer* *read-only-space-free-pointer*)
"VM")
(in-package "VM")
;;;; Type format database.
(eval-when (compile load eval)
(defstruct (room-info (:make-load-form-fun :just-dump-it-normally))
;;
;; The name of this type.
(name nil :type symbol)
;;
;; Kind of type (how we determine length).
(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 nil :type (or fixnum null))))
(eval-when (compile eval)
(defvar *meta-room-info* (make-array 256 :initial-element nil))
(dolist (obj *primitive-objects*)
(let ((header (primitive-object-header obj))
(lowtag (primitive-object-lowtag obj))
(name (primitive-object-name obj))
(variable (primitive-object-variable-length obj))
(size (primitive-object-size obj)))
(cond
((not lowtag))
((not header)
(let ((info (make-room-info :name name :kind :lowtag))
(lowtag (symbol-value lowtag)))
(declare (fixnum lowtag))
(dotimes (i 32)
(setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
(variable)
(t
(setf (svref *meta-room-info* (symbol-value header))
(make-room-info :name name :kind :fixed :length size))))))
(dolist (code (list complex-string-type simple-array-type
complex-bit-vector-type complex-vector-type
complex-array-type))
(setf (svref *meta-room-info* code)
(make-room-info :name 'array-header :kind :header)))
(setf (svref *meta-room-info* bignum-type)
(make-room-info :name 'bignum :kind :header))
(setf (svref *meta-room-info* closure-header-type)
(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)
#+double-double
(simple-array-double-double-float-type . 4)
#+double-double
(simple-array-complex-double-double-float-type . 5)
))
(let ((name (car stuff))
(size (cdr stuff)))
(setf (svref *meta-room-info* (symbol-value name))
(make-room-info :name name :kind :vector :length size))))
;; For unicode, there are 2 bytes per character, not 1.
(setf (svref *meta-room-info* simple-string-type)
(make-room-info :name 'simple-string-type :kind :string
;; Assumes char-bytes is a power of two!
:length (1- (integer-length vm:char-bytes))))
(setf (svref *meta-room-info* code-header-type)
(make-room-info :name 'code :kind :code))
(setf (svref *meta-room-info* instance-header-type)
(make-room-info :name 'instance :kind :instance))
); eval-when (compile eval)
(defparameter *room-info* '#.*meta-room-info*)
(deftype spaces () '(member :static :dynamic :read-only))
;; A type denoting the virtual address available to us.
(deftype memory-size () `(unsigned-byte #.vm:word-bits))
;;;; MAP-ALLOCATED-OBJECTS:
(declaim (type fixnum *static-space-free-pointer*
*read-only-space-free-pointer* ))
#+gencgc
(eval-when (compile load eval)
;; This had better match the value in gencgc.h!!!!
(defconstant gencgc-page-size
#+sparc (* 4 8192)
#+ppc (* 4 4096)
#-(or sparc ppc) 4096))
#+gencgc
(def-alien-variable last-free-page c-call:unsigned-int)
(defun space-bounds (space)
(declare (type spaces space))
(ecase space
(:static
(values (int-sap (static-space-start))
(int-sap (* *static-space-free-pointer* word-bytes))))
(:read-only
(values (int-sap (read-only-space-start))
(int-sap (* *read-only-space-free-pointer* word-bytes))))
(:dynamic
;; DYNAMIC-SPACE-FREE-POINTER isn't quite right here for sparc
;; and ppc with gencgc. We really want the last free page, which
;; is stored in *allocation-pointer* on x86, but sparc and ppc
;; don't have *allocation-pointer*, so grab the value directly
;; from last-free-page.
(values (int-sap (current-dynamic-space-start))
#+(and gencgc (or sparc ppc))
(int-sap (truly-the (unsigned-byte 32)
(+ (current-dynamic-space-start)
(the (unsigned-byte 32) (* gencgc-page-size last-free-page)))))
#-(and gencgc (or sparc ppc))
(dynamic-space-free-pointer)))))
;;; SPACE-BYTES -- Internal
;;;
;;; Return the total number of bytes used in Space.
;;;
(defun space-bytes (space)
(multiple-value-bind (start end)
(space-bounds space)
(- (sap-int end) (sap-int start))))
;;; ROUND-TO-DUALWORD -- Internal
;;;
;;; Round Size (in bytes) up to the next dualword (eight/16 byte) boundry.
;;;
(declaim (inline round-to-dualword))
(defun round-to-dualword (size)
(declare (type memory-size size))
#-amd64
(logandc2 (the memory-size (+ size lowtag-mask)) lowtag-mask)
;; when we use 4-bit lowtag for amd64 we can get rid of this
#+amd64
(logandc2 (the memory-size (+ size 15)) 15))
;;; VECTOR-TOTAL-SIZE -- Internal
;;;
;;; Return the total size of a vector in bytes, including any pad.
;;;
(declaim (inline vector-total-size))
(defun vector-total-size (obj info)
(let ((shift (room-info-length info))
(len (+ (length (the (simple-array * (*)) obj))
(ecase (room-info-kind info)
(:vector 0)
(:string 1)))))
(declare (type (integer -3 3) shift))
(round-to-dualword
(+ (* vector-data-offset word-bytes)
(the memory-size
(if (minusp shift)
(ash (the memory-size
(+ len (the memory-size
(1- (the memory-size (ash 1 (- shift)))))))
shift)
(ash len shift)))))))
;;; Access to the GENCGC page table for better precision in
;;; MAP-ALLOCATED-OBJECTS.
#+gencgc
(progn
(declaim (inline find-page-index get-page-table-info))
(def-alien-routine "find_page_index" c-call:int
(addr c-call:long))
(def-alien-routine get-page-table-info c-call:void
(page c-call:int)
(flags c-call:int :out)
(bytes c-call:int :out))
)
;;; MAP-ALLOCATED-OBJECTS -- Interface
;;;
;;; Iterate over all the objects allocated in Space, calling Fun with the
;;; object, the object's type code, and the objects total size in bytes,
;;; including any header and padding.
;;;
(declaim (maybe-inline map-allocated-objects))
#+nil
(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)))
(iterate step ((current start))
(flet ((next (size)
(let ((c (etypecase size
(fixnum (sap+ current size))
(memory-size (sap+ current size)))))
(cond ((sap< c end)
(step c))
(t
(assert (sap= c end)))))))
(let* ((header (sap-ref-32 current 0))
(header-type (logand header #xFF))
(info (svref *room-info* header-type)))
(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
size)
(next size)))
((eql header-type closure-header-type)
(let* ((obj (make-lisp-obj (logior (sap-int current)
function-pointer-type)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
(funcall fun obj header-type size)
(next size)))
((eq (room-info-kind info) :instance)
(let* ((obj (make-lisp-obj
(logior (sap-int current) instance-pointer-type)))
(size (round-to-dualword
(* (+ (%instance-length obj) 1) word-bytes))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000) (break "Implausible size, prev ~S" prev))
#+nil
(setq prev current)
(next size)))
(t
(let* ((obj (make-lisp-obj
(logior (sap-int current) other-pointer-type)))
(size (ecase (room-info-kind info)
(:fixed
(assert (or (eql (room-info-length info)
(1+ (get-header-data obj)))
(floatp obj)))
(round-to-dualword
(* (room-info-length info) word-bytes)))
((:vector :string)
(vector-total-size obj info))
(:header
(round-to-dualword
(* (1+ (get-header-data obj)) word-bytes)))
(:code
(+ (the fixnum
(* (get-header-data obj) word-bytes))
(round-to-dualword
(* (the fixnum (%code-code-size obj))
word-bytes)))))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000)
(break "Implausible size, prev ~S" prev))
#+nil
(setq prev current)
(next size))))))
#+nil
prev))))
(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 ((skip-tests-until-addr 0)
(current start))
(declare (type (unsigned-byte 31) skip-tests-until-addr))
(labels
((maybe-finish-mapping ()
(unless (sap< current end)
(return-from map-allocated-objects)))
;; GENCGC doesn't allocate linearly, which means that the
;; dynamic space can contain large blocks of 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)
(let ((tested (>= (sap-int current) skip-tests-until-addr)))
(loop with page-mask = (1- gencgc-page-size)
for addr of-type (unsigned-byte 32) = (sap-int current)
while (>= addr skip-tests-until-addr)
do
(multiple-value-bind (ret flags bytes-used)
(get-page-table-info (find-page-index addr))
(declare (ignore ret))
(let ((alloc-flag (logand flags #x40)))
;; 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)
gencgc-page-size)))
(maybe-finish-mapping)))))))
(next (size)
(let ((c (etypecase size
(fixnum (sap+ current size))
(memory-size (sap+ current size)))))
(setf current c))))
(declare (inline next maybe-finish-mapping))
(loop
(maybe-finish-mapping)
(maybe-skip-page)
(let* ((header (sap-ref-32 current 0))
(header-type (logand header #xFF))
(info (svref *room-info* header-type)))
(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
size)
(next size)))
((eql header-type closure-header-type)
(let* ((obj (make-lisp-obj (logior (sap-int current)
function-pointer-type)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
(funcall fun obj header-type size)
(next size)))
((eq (room-info-kind info) :instance)
(let* ((obj (make-lisp-obj
(logior (sap-int current) instance-pointer-type)))
(size (round-to-dualword
(* (+ (%instance-length obj) 1) word-bytes))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
(next size)))
(t
(let* ((obj (make-lisp-obj
(logior (sap-int current) other-pointer-type)))
(size (ecase (room-info-kind info)
(:fixed
(assert (or (eql (room-info-length info)
(1+ (get-header-data obj)))
(floatp obj)))
(round-to-dualword
(* (room-info-length info) word-bytes)))
((:vector :string)
(vector-total-size obj info))
(:header
(round-to-dualword
(* (1+ (get-header-data obj)) word-bytes)))
(:code
(+ (the fixnum
(* (get-header-data obj) word-bytes))
(round-to-dualword
(* (the fixnum (%code-code-size obj))
word-bytes)))))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
(next size)))))))))))
;;;; MEMORY-USAGE:
;;; TYPE-BREAKDOWN -- Interface
;;;
;;; 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 '(unsigned-byte 32)))
(counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32))))
(map-allocated-objects
#'(lambda (obj type size)
(declare (type memory-size size) (optimize (speed 3) (safety 0)) (ignore obj))
(incf (aref sizes type) size)
(incf (aref counts type)))
space)
(let ((totals (make-hash-table :test #'eq)))
(dotimes (i 256)
(let ((total-count (aref counts i)))
(unless (zerop total-count)
(let* ((total-size (aref sizes i))
(name (room-info-name (aref *room-info* i)))
(found (gethash name totals)))
(cond (found
(incf (first found) total-size)
(incf (second found) total-count))
(t
(setf (gethash name totals)
(list total-size total-count name))))))))
(collect ((totals-list))
(maphash #'(lambda (k v)
(declare (ignore k))
(totals-list v))
totals)
(sort (totals-list) #'> :key #'first)))))
;;; PRINT-SUMMARY -- Internal
;;;
;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
;;; (space-name . totals-for-space), where totals-for-space is the list
;;; returned by TYPE-BREAKDOWN.
;;;
(defun print-summary (spaces totals)
(let ((summary (make-hash-table :test #'eq)))
(dolist (space-total totals)
(dolist (total (cdr space-total))
(push (cons (car space-total) total)
(gethash (third total) summary))))
(collect ((summary-totals))
(maphash #'(lambda (k v)
(declare (ignore k))
(let ((sum 0))
(declare (type memory-size sum))
(dolist (space-total v)
(incf sum (first (cdr space-total))))
(summary-totals (cons sum v))))
summary)
(format t (intl:gettext "~2&Summary of spaces: ~(~{~A ~}~)~%") spaces)
(let ((summary-total-bytes 0)
(summary-total-objects 0))
(declare (type memory-size 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)
(type memory-size total-bytes))
(collect ((spaces))
(dolist (space-total space-totals)
(let ((total (cdr space-total)))
(setq name (third total))
(incf total-bytes (first total))
(incf total-objects (second total))
(spaces (cons (car space-total) (first total)))))
(format t (intl:ngettext "~%~A:~% ~:D bytes, ~:D object"
"~%~A:~% ~:D bytes, ~:D objects"
total-objects)
name total-bytes total-objects)
(dolist (space (spaces))
(format t ", ~D% ~(~A~)"
(round (* (cdr space) 100) total-bytes)
(car space)))
(format t ".~%")
(incf summary-total-bytes total-bytes)
(incf summary-total-objects total-objects))))
(format t (intl:gettext "~%Summary total:~% ~:D bytes, ~:D objects.~%")
summary-total-bytes summary-total-objects)))))
;;; REPORT-SPACE-TOTAL -- Internal
;;;
;;; Report object usage for a single space.
;;;
(defun report-space-total (space-total cutoff)
(declare (list space-total) (type (or single-float null) cutoff))
(format t (intl:gettext "~2&Breakdown for ~(~A~) space:~%") (car space-total))
(let* ((types (cdr space-total))
(total-bytes (reduce #'+ (mapcar #'first types)))
(total-objects (reduce #'+ (mapcar #'second types)))
(cutoff-point (if cutoff
(truncate (* (float total-bytes) cutoff))
0))
(reported-bytes 0)
(reported-objects 0))
(declare (fixnum total-objects cutoff-point reported-objects)
(type memory-size total-bytes reported-bytes))
(loop for (bytes objects name) in types do
(when (<= bytes cutoff-point)
(format t (intl:ngettext " ~13:D bytes for ~9:D other object.~%"
" ~13:D bytes for ~9:D other objects.~%"
(- total-objects reported-objects))
(- total-bytes reported-bytes)
(- total-objects reported-objects))
(return))
(incf reported-bytes bytes)
(incf reported-objects objects)
(format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object.~%"
" ~13:D bytes for ~9:D ~(~A~) objects.~%"
objects)
bytes objects name))
(format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object (space total.)~%"
" ~13:D bytes for ~9:D ~(~A~) objects (space total.)~%"
total-objects)
total-bytes total-objects (car space-total))))
;;; MEMORY-USAGE -- Public
;;;
(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
(print-summary t) cutoff)
"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)
count-spaces))
(totals (mapcar #'(lambda (space)
(cons space (type-breakdown space)))
spaces)))
(dolist (space-total totals)
(when (or (eq print-spaces t)
(member (car space-total) print-spaces))
(report-space-total space-total cutoff)))
(when print-summary (print-summary spaces totals)))
(values))
;;; COUNT-NO-OPS -- Public
;;;
(defun count-no-ops (space)
"Print info about how much code and no-ops there are in Space."
(declare (type spaces space))
(let ((code-words 0)
(no-ops 0)
(total-bytes 0))
(declare (fixnum code-words no-ops)
(type unsigned-byte total-bytes))
(map-allocated-objects
#'(lambda (obj type size)
(declare (fixnum size) (optimize (safety 0)))
(when (eql type code-header-type)
(incf total-bytes size)
(let ((words (truly-the fixnum (%code-code-size obj)))
(sap (truly-the system-area-pointer
(%primitive code-instructions obj))))
(incf code-words words)
(dotimes (i words)
(when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
(incf no-ops))))))
space)
(format t
(intl:gettext "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%")
total-bytes code-words no-ops
(round (* no-ops 100) code-words)))
(values))
;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
;;;
(defun descriptor-vs-non-descriptor-storage (&rest spaces)
(let ((descriptor-words 0)
(non-descriptor-headers 0)
(non-descriptor-bytes 0))
(declare (type unsigned-byte descriptor-words non-descriptor-headers
non-descriptor-bytes))
(dolist (space (or spaces '(:read-only :static :dynamic)))
(declare (inline map-allocated-objects))
(map-allocated-objects
#'(lambda (obj type size)
(declare (fixnum size) (optimize (safety 0)))
(case type
(#.code-header-type
(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
#+double-double
#.double-double-float-type
#.complex-single-float-type
#.complex-double-float-type
#+double-double
#.complex-double-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
#+double-double
#.simple-array-double-double-float-type
#.simple-array-complex-single-float-type
#.simple-array-complex-double-float-type
#+double-double
#.simple-array-complex-double-double-float-type)
(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
#.fdefn-type
#+gencgc
#.scavenger-hook-type)
(incf descriptor-words (truncate size word-bytes)))
(t
(error (intl:gettext "Bogus type: ~D") type))))
space))
(format t (intl:gettext "~:D words allocated for descriptor objects.~%")
descriptor-words)
(format t (intl:gettext "~:D bytes data/~:D words header for non-descriptor objects.~%")
non-descriptor-bytes non-descriptor-headers)
(values)))
;;; INSTANCE-USAGE -- Public
;;;
(defun instance-usage (space &key (top-n 15))
(declare (type spaces space) (type (or fixnum null) top-n))
"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 (intl:gettext "~2&~@[Top ~D ~]~(~A~) instance types:~%") top-n space)
(let ((totals (make-hash-table :test #'eq))
(total-objects 0)
(total-bytes 0))
(declare (fixnum total-objects)
(type memory-size total-bytes))
(map-allocated-objects
#'(lambda (obj type size)
(declare (type memory-size size) (optimize (speed 3) (safety 0)))
(when (eql type instance-header-type)
(incf total-objects)
(incf total-bytes size)
(let* ((class (layout-class (%instance-ref obj 0)))
(found (gethash class totals)))
(cond (found
(incf (the fixnum (car found)))
(incf (the fixnum (cdr found)) size))
(t
(setf (gethash class totals) (cons 1 size)))))))
space)
(collect ((totals-list))
(maphash #'(lambda (class what)
(totals-list (cons (prin1-to-string
(class-proper-name class))
what)))
totals)
(let ((sorted (sort (totals-list) #'> :key #'cddr))
(printed-bytes 0)
(printed-objects 0))
(declare (type memory-size printed-bytes printed-objects))
(dolist (what (if top-n
(subseq sorted 0 (min (length sorted) top-n))
sorted))
(let ((bytes (cddr what))
(objects (cadr what)))
(incf printed-bytes bytes)
(incf printed-objects objects)
(format t (intl:ngettext " ~32A: ~7:D bytes, ~5D object.~%"
" ~32A: ~7:D bytes, ~5D objects.~%"
objects)
(car what)
bytes objects)))
(let ((residual-objects (- total-objects printed-objects))
(residual-bytes (- total-bytes printed-bytes)))
(unless (zerop residual-objects)
(format t (intl:ngettext " Other types: ~:D bytes, ~D: object~:P.~%"
" Other types: ~:D bytes, ~D: object~:P.~%"
residual-objects)
residual-bytes residual-objects))))
(format t (intl:ngettext " ~:(~A~) instance total: ~:D bytes, ~:D object.~%"
" ~:(~A~) instance total: ~:D bytes, ~:D objects.~%"
total-objects)
space total-bytes total-objects)))
(values))
;;; FIND-HOLES -- Public
;;;
(defun find-holes (&rest spaces)
(dolist (space (or spaces '(:read-only :static :dynamic)))
(format t (intl:gettext "In ~A space:~%") space)
(let ((start-addr nil)
(total-bytes 0))
(declare (type (or null (unsigned-byte 32)) start-addr)
(type (unsigned-byte 32) total-bytes))
(map-allocated-objects
#'(lambda (object typecode bytes)
(declare (ignore typecode)
(type (unsigned-byte 32) bytes))
(if (and (consp object)
(eql (car object) 0)
(eql (cdr object) 0))
(if start-addr
(incf total-bytes bytes)
(setf start-addr (di::get-lisp-obj-address object)
total-bytes bytes))
(when start-addr
(format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr)
(setf start-addr nil))))
space)
(when start-addr
(format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr))))
(values))
;;; Print allocated objects:
(defun print-allocated-objects (space &key (percent 0) (pages 5)
type larger smaller count
(stream *standard-output*))
(declare (type (integer 0 99) percent) (type c::index pages)
(type stream stream) (type spaces space)
(type (or c::index null) type larger smaller count))
(multiple-value-bind (start-sap end-sap)
(space-bounds space)
(let* ((space-start (sap-int start-sap))
(space-end (sap-int end-sap))
(space-size (- space-end space-start))
(pagesize (system:get-page-size))
(start (+ space-start (round (* space-size percent) 100)))
(printed-conses (make-hash-table :test #'eq))
(pages-so-far 0)
(count-so-far 0)
(last-page 0))
(declare (type (unsigned-byte 32) last-page start)
(fixnum pages-so-far count-so-far pagesize))
(labels ((note-conses (x)
(unless (or (atom x) (gethash x printed-conses))
(setf (gethash x printed-conses) t)
(note-conses (car x))
(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
(> count-so-far count)
(> pages-so-far pages))
(return-from print-allocated-objects (values)))
(unless count
(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)
(format stream "~2&**** Page ~D, address ~X:~%"
pages-so-far addr))
(setq last-page this-page)
(incf pages-so-far))))
(when (and (or (not type) (eql obj-type type))
(or (not smaller) (<= size smaller))
(or (not larger) (>= size larger)))
(incf count-so-far)
(case type
(#.code-header-type
(let ((dinfo (%code-debug-info obj)))
(format stream "~&Code object: ~S~%"
(if dinfo
(c::compiled-debug-info-name dinfo)
"No debug info."))))
(#.symbol-header-type
(format stream "~&~S~%" obj))
(#.list-pointer-type
(unless (gethash obj printed-conses)
(note-conses obj)
(let ((*print-circle* t)
(*print-level* 5)
(*print-length* 10))
(format stream "~&~S~%" obj))))
(t
(fresh-line stream)
(let ((str (write-to-string obj :level 5 :length 10
:pretty nil)))
(unless (eql type instance-header-type)
(format stream "~S: " (type-of obj)))
(format stream "~A~%"
(subseq str 0 (min (length str) 60))))))))))
space))))
(values))
;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
(defvar *ignore-after* nil)
(defun maybe-cons (space x stuff)
(if (or (not (eq space :dynamic))
(< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
(cons x stuff)
stuff))
(defun list-allocated-objects (space &key type larger smaller count
test)
(declare (type spaces space)
(type (or c::index null) larger smaller type count)
(type (or function null) test)
(inline map-allocated-objects))
(unless *ignore-after* (setq *ignore-after* (cons 1 2)))
(collect ((counted 0 1+))
(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))
(or (not test) (funcall test obj)))
(setq res (maybe-cons space obj res))
(when (and count (>= (counted) count))
(return-from list-allocated-objects res))))
space)
res)))
(defun list-referencing-objects (space object)
(declare (type spaces space) (inline map-allocated-objects))
(unless *ignore-after* (setq *ignore-after* (cons 1 2)))
(let ((res ()))
(flet ((res (x)
(setq res (maybe-cons space x res))))
(map-allocated-objects
#'(lambda (obj obj-type size)
(declare (optimize (safety 0)) (ignore obj-type size))
(typecase obj
(cons
(when (or (eq (car obj) object) (eq (cdr obj) object))
(res obj)))
(instance
(dotimes (i (%instance-length obj))
(when (eq (%instance-ref obj i) object)
(res obj)
(return))))
(simple-vector
(dotimes (i (length obj))
(when (eq (svref obj i) object)
(res obj)
(return))))
(symbol
(when (or (eq (symbol-name obj) object)
(eq (symbol-package obj) object)
(eq (symbol-plist obj) object)
(eq (symbol-value obj) object))
(res obj)))))
space))
res))
;;;; Misc:
(defun uninterned-symbol-count (space)
(declare (type spaces space))
(let ((total 0)
(uninterned 0))
(map-allocated-objects
#'(lambda (obj type size)
(declare (ignore type size))
(when (symbolp obj)
(incf total)
(unless (symbol-package obj)
(incf uninterned))))
space)
(values uninterned (float (/ uninterned total)))))
(defun code-breakdown (space &key (how :package))
(declare (type spaces space) (type (member :file :package) how))
(let ((packages (make-hash-table :test #'equal)))
(map-allocated-objects
#'(lambda (obj type size)
(when (eql type code-header-type)
(let* ((dinfo (let ((x (%code-debug-info obj)))
(when (typep x 'c::debug-info) x)))
(package (if (typep dinfo 'c::compiled-debug-info)
(c::compiled-debug-info-package dinfo)
"UNKNOWN"))
(pkg-info (or (gethash package packages)
(setf (gethash package packages)
(make-hash-table :test #'equal))))
(file
(if dinfo
(let ((src (c::debug-info-source dinfo)))
(cond (src
(let ((source
(first
(c::debug-info-source
dinfo))))
(if (eq (c::debug-source-from source)
:file)
(c::debug-source-name source)
"FROM LISP")))
(t
(warn (intl:gettext "No source for ~S") obj)
"NO SOURCE")))
"UNKNOWN"))
(file-info (or (gethash file pkg-info)
(setf (gethash file pkg-info)
(cons 0 0)))))
(incf (car file-info))
(incf (cdr file-info) size))))
space)
(let ((res ()))
(do-hash (pkg pkg-info packages)
(let ((pkg-res ())
(pkg-count 0)
(pkg-size 0))
(do-hash (file file-info pkg-info)
(incf pkg-count (car file-info))
(incf pkg-size (cdr file-info))
(push (list file file-info) pkg-res))
(push (cons pkg-count pkg-size) pkg-res)
(push pkg pkg-res)
(push pkg-res res)))
(loop for (pkg (pkg-count . pkg-size) . files) in
(sort res #'> :key #'(lambda (x) (cdr (second x)))) do
(format t (intl:ngettext "~%Package ~A: ~32T~9:D bytes, ~9:D object.~%"
"~%Package ~A: ~32T~9:D bytes, ~9:D objects.~%"
pkg-count)
pkg pkg-size pkg-count)
(when (eq how :file)
(loop for (file (file-count . file-size)) in
(sort files #'> :key #'(lambda (x) (cdr (second x)))) do
(format t (intl:ngettext "~30@A: ~9:D bytes, ~9:D object.~%"
"~30@A: ~9:D bytes, ~9:D objects.~%"
file-count)
(file-namestring file) file-size file-count))))))
(values))
;;;; Histogram interface. Uses Scott's Hist package.
#+nil
(defun memory-histogram (space &key (low 4) (high 20)
(bucket-size 1)
(function
#'(lambda (obj type size)
(declare (ignore obj type) (fixnum size))
(integer-length (1- size))))
(type nil))
(let ((function (if (eval:interpreted-function-p function)
(compile nil function)
function)))
(hist:hist (low high bucket-size)
(map-allocated-objects
#'(lambda (obj this-type size)
(when (or (not type) (eql this-type type))
(hist:hist-record (funcall function obj type size))))
space)))
(values))
;;; Return the number of fbound constants in a code object.
;;;
(defun code-object-calls (obj)
(loop for i from code-constants-offset below (get-header-data obj)
count (find-code-object (code-header-ref obj i))))
;;; Return the number of calls in Obj to functions with <= N calls. Calls is
;;; an eq hashtable translating code objects to the number of references.
;;;
(defun code-object-leaf-calls (obj n calls)
(loop for i from code-constants-offset below (get-header-data obj)
count (let ((code (find-code-object (code-header-ref obj i))))
(and code (<= (gethash code calls 0) n)))))
#+nil
(defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
(function #'identity))
_N"Given a hashtable, print a histogram of the contents. Function should give
the value to plot when applied to the hashtable values."
(let ((function (if (eval:interpreted-function-p function)
(compile nil function)
function)))
(hist:hist (low high bucket-size)
(loop for count being each hash-value in table do
(hist:hist-record (funcall function count))))))
(defun report-top-n (table &key (top-n 20) (function #'identity))
"Report the Top-N entries in the hashtable Table, when sorted by Function
applied to the hash value. If Top-N is NIL, report all entries."
(let ((function (if (eval:interpreted-function-p function)
(compile nil function)
function)))
(collect ((totals-list)
(total-val 0 +))
(maphash #'(lambda (name what)
(let ((val (funcall function what)))
(totals-list (cons name val))
(total-val val)))
table)
(let ((sorted (sort (totals-list) #'> :key #'cdr))
(printed 0))
(declare (fixnum printed))
(dolist (what (if top-n
(subseq sorted 0 (min (length sorted) top-n))
sorted))
(let ((val (cdr what)))
(incf printed val)
(format t "~8:D: ~S~%" val (car what))))
(let ((residual (- (total-val) printed)))
(unless (zerop residual)
(format t (intl:gettext "~8:D: Other~%") residual))))
(format t (intl:gettext "~8:D: Total~%") (total-val))))
(values))
;;; Given any Lisp object, return the associated code object, or NIL.
;;;
(defun find-code-object (const)
(flet ((frob (def)
(function-code-header
(ecase (get-type def)
((#.closure-header-type
#.funcallable-instance-header-type)
(%closure-function def))
(#.function-header-type
def)))))
(typecase const
(function (frob const))
(symbol
(if (fboundp const)
(frob (symbol-function const))
nil))
(t nil))))
(defun find-caller-counts (space)
"Return a hashtable mapping each function in for which a call appears in
Space to the number of times such a call appears."
(let ((counts (make-hash-table :test #'eq)))
(map-allocated-objects
#'(lambda (obj type size)
(declare (ignore size))
(when (eql type code-header-type)
(loop for i from code-constants-offset below (get-header-data obj)
do (let ((code (find-code-object (code-header-ref obj i))))
(when code
(incf (gethash code counts 0)))))))
space)
counts))
(defun find-high-callers (space &key (above 10) table (threshold 2))
"Return a hashtable translating code objects to function constant counts for
all code objects in Space with more than Above function constants."
(let ((counts (make-hash-table :test #'eq)))
(map-allocated-objects
#'(lambda (obj type size)
(declare (ignore size))
(when (eql type code-header-type)
(let ((count (if table
(code-object-leaf-calls obj threshold table)
(code-object-calls obj))))
(when (> count above)
(setf (gethash obj counts) count)))))
space)
counts))