src/code/room.lisp

   1 ;;;; heap-grovelling memory usage stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; type format database
  15
  16 (eval-when (:compile-toplevel :load-toplevel :execute)
  17   (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
  18     ;; the name of this type
  19     (name nil :type symbol)
  20     ;; kind of type (how we determine length)
  21     (kind (missing-arg)
  22           :type (member :lowtag :fixed :header :vector
  23                         :string :code :closure :instance))
  24     ;; length if fixed-length, shift amount for element size if :VECTOR
  25     (length nil :type (or fixnum null))))
  26
  27 (eval-when (:compile-toplevel :execute)
  28
  29 (defvar *meta-room-info* (make-array 256 :initial-element nil))
  30
  31 (dolist (obj *primitive-objects*)
  32   (let ((widetag (primitive-object-widetag obj))
  33         (lowtag (primitive-object-lowtag obj))
  34         (name (primitive-object-name obj))
  35         (variable (primitive-object-variable-length-p obj))
  36         (size (primitive-object-size obj)))
  37     (cond
  38      ((not lowtag))
  39      ((not widetag)
  40       (let ((info (make-room-info :name name
  41                                   :kind :lowtag))
  42             (lowtag (symbol-value lowtag)))
  43         (declare (fixnum lowtag))
  44         (dotimes (i 32)
  45           (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
  46      (variable)
  47      (t
  48       (setf (svref *meta-room-info* (symbol-value widetag))
  49             (make-room-info :name name
  50                             :kind :fixed
  51                             :length size))))))
  52
  53 (dolist (code (list complex-base-string-widetag simple-array-widetag
  54                     complex-bit-vector-widetag complex-vector-widetag
  55                     complex-array-widetag complex-vector-nil-widetag))
  56   (setf (svref *meta-room-info* code)
  57         (make-room-info :name 'array-header
  58                         :kind :header)))
  59
  60 (setf (svref *meta-room-info* bignum-widetag)
  61       (make-room-info :name 'bignum
  62                       :kind :header))
  63
  64 (setf (svref *meta-room-info* closure-header-widetag)
  65       (make-room-info :name 'closure
  66                       :kind :closure))
  67
  68 (dolist (stuff '((simple-bit-vector-widetag . -3)
  69                  (simple-vector-widetag . 2)
  70                  (simple-array-unsigned-byte-2-widetag . -2)
  71                  (simple-array-unsigned-byte-4-widetag . -1)
  72                  (simple-array-unsigned-byte-7-widetag . 0)
  73                  (simple-array-unsigned-byte-8-widetag . 0)
  74                  (simple-array-unsigned-byte-15-widetag . 1)
  75                  (simple-array-unsigned-byte-16-widetag . 1)
  76                  (simple-array-unsigned-byte-31-widetag . 2)
  77                  (simple-array-unsigned-byte-32-widetag . 2)
  78                  (simple-array-signed-byte-8-widetag . 0)
  79                  (simple-array-signed-byte-16-widetag . 1)
  80                  (simple-array-unsigned-byte-29-widetag . 2)
  81                  (simple-array-signed-byte-30-widetag . 2)
  82                  (simple-array-signed-byte-32-widetag . 2)
  83                  (simple-array-single-float-widetag . 2)
  84                  (simple-array-double-float-widetag . 3)
  85                  (simple-array-complex-single-float-widetag . 3)
  86                  (simple-array-complex-double-float-widetag . 4)))
  87   (let* ((name (car stuff))
  88          (size (cdr stuff))
  89          (sname (string name)))
  90     (setf (svref *meta-room-info* (symbol-value name))
  91           (make-room-info :name (intern (subseq sname
  92                                                 0
  93                                                 (mismatch sname "-WIDETAG"
  94                                                           :from-end t)))
  95                           :kind :vector
  96                           :length size))))
  97
  98 (setf (svref *meta-room-info* simple-base-string-widetag)
  99       (make-room-info :name 'simple-base-string
 100                       :kind :string
 101                       :length 0))
 102
 103 (setf (svref *meta-room-info* simple-array-nil-widetag)
 104       (make-room-info :name 'simple-array-nil
 105                       :kind :fixed
 106                       :length 2))
 107
 108 (setf (svref *meta-room-info* code-header-widetag)
 109       (make-room-info :name 'code
 110                       :kind :code))
 111
 112 (setf (svref *meta-room-info* instance-header-widetag)
 113       (make-room-info :name 'instance
 114                       :kind :instance))
 115
 116 ) ; EVAL-WHEN
 117
 118 (defparameter *room-info* '#.*meta-room-info*)
 119 (deftype spaces () '(member :static :dynamic :read-only))
 120 \f
 121 ;;;; MAP-ALLOCATED-OBJECTS
 122
 123 ;;; Since they're represented as counts of words, we should never
 124 ;;; need bignums to represent these:
 125 (declaim (type fixnum
 126                *static-space-free-pointer*
 127                *read-only-space-free-pointer*))
 128
 129 (defun space-bounds (space)
 130   (declare (type spaces space))
 131   (ecase space
 132     (:static
 133      (values (int-sap static-space-start)
 134              (int-sap (* *static-space-free-pointer* n-word-bytes))))
 135     (:read-only
 136      (values (int-sap read-only-space-start)
 137              (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
 138     (:dynamic
 139      (values (int-sap #!+gencgc dynamic-space-start
 140                       #!-gencgc (current-dynamic-space-start))
 141              (dynamic-space-free-pointer)))))
 142
 143 ;;; Return the total number of bytes used in SPACE.
 144 (defun space-bytes (space)
 145   (multiple-value-bind (start end) (space-bounds space)
 146     (- (sap-int end) (sap-int start))))
 147
 148 ;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
 149 #!-sb-fluid (declaim (inline round-to-dualword))
 150 (defun round-to-dualword (size)
 151   (declare (fixnum size))
 152   (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
 153
 154 ;;; Return the total size of a vector in bytes, including any pad.
 155 #!-sb-fluid (declaim (inline vector-total-size))
 156 (defun vector-total-size (obj info)
 157   (let ((shift (room-info-length info))
 158         (len (+ (length (the (simple-array * (*)) obj))
 159                 (ecase (room-info-kind info)
 160                   (:vector 0)
 161                   (:string 1)))))
 162     (declare (type (integer -3 3) shift))
 163     (round-to-dualword
 164      (+ (* vector-data-offset n-word-bytes)
 165         (the fixnum
 166              (if (minusp shift)
 167                  (ash (the fixnum
 168                            (+ len (the fixnum
 169                                        (1- (the fixnum (ash 1 (- shift)))))))
 170                       shift)
 171                  (ash len shift)))))))
 172
 173 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 174 ;;; the object, the object's type code, and the objects total size in
 175 ;;; bytes, including any header and padding.
 176 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 177 (defun map-allocated-objects (fun space)
 178   (declare (type function fun) (type spaces space))
 179   (without-gcing
 180     (multiple-value-bind (start end) (space-bounds space)
 181       (declare (type system-area-pointer start end))
 182       (declare (optimize (speed 3) (safety 0)))
 183       (let ((current start)
 184             #+nil
 185             (prev nil))
 186         (loop
 187           (let* ((header (sap-ref-32 current 0))
 188                  (header-widetag (logand header #xFF))
 189                  (info (svref *room-info* header-widetag)))
 190             (cond
 191              ((or (not info)
 192                   (eq (room-info-kind info) :lowtag))
 193               (let ((size (* cons-size n-word-bytes)))
 194                 (funcall fun
 195                          (make-lisp-obj (logior (sap-int current)
 196                                                 list-pointer-lowtag))
 197                          list-pointer-lowtag
 198                          size)
 199                 (setq current (sap+ current size))))
 200              ((eql header-widetag closure-header-widetag)
 201               (let* ((obj (make-lisp-obj (logior (sap-int current)
 202                                                  fun-pointer-lowtag)))
 203                      (size (round-to-dualword
 204                             (* (the fixnum (1+ (get-closure-length obj)))
 205                                n-word-bytes))))
 206                 (funcall fun obj header-widetag size)
 207                 (setq current (sap+ current size))))
 208              ((eq (room-info-kind info) :instance)
 209               (let* ((obj (make-lisp-obj
 210                            (logior (sap-int current) instance-pointer-lowtag)))
 211                      (size (round-to-dualword
 212                             (* (+ (%instance-length obj) 1) n-word-bytes))))
 213                 (declare (fixnum size))
 214                 (funcall fun obj header-widetag size)
 215                 (aver (zerop (logand size lowtag-mask)))
 216                 #+nil
 217                 (when (> size 200000) (break "implausible size, prev ~S" prev))
 218                 #+nil
 219                 (setq prev current)
 220                 (setq current (sap+ current size))))
 221              (t
 222               (let* ((obj (make-lisp-obj
 223                            (logior (sap-int current) other-pointer-lowtag)))
 224                      (size (ecase (room-info-kind info)
 225                              (:fixed
 226                               (aver (or (eql (room-info-length info)
 227                                                (1+ (get-header-data obj)))
 228                                         (floatp obj)
 229                                         (simple-array-nil-p obj)))
 230                               (round-to-dualword
 231                                (* (room-info-length info) n-word-bytes)))
 232                              ((:vector :string)
 233                               (vector-total-size obj info))
 234                              (:header
 235                               (round-to-dualword
 236                                (* (1+ (get-header-data obj)) n-word-bytes)))
 237                              (:code
 238                               (+ (the fixnum
 239                                       (* (get-header-data obj) n-word-bytes))
 240                                  (round-to-dualword
 241                                   (* (the fixnum (%code-code-size obj))
 242                                      n-word-bytes)))))))
 243                 (declare (fixnum size))
 244                 (funcall fun obj header-widetag size)
 245                 (aver (zerop (logand size lowtag-mask)))
 246                 #+nil
 247                 (when (> size 200000)
 248                   (break "Implausible size, prev ~S" prev))
 249                 #+nil
 250                 (setq prev current)
 251                 (setq current (sap+ current size))))))
 252           (unless (sap< current end)
 253             (aver (sap= current end))
 254             (return)))
 255
 256         #+nil
 257         prev))))
 258 \f
 259 ;;;; MEMORY-USAGE
 260
 261 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 262 ;;; allocated in Space.
 263 (defun type-breakdown (space)
 264   (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
 265         (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
 266     (map-allocated-objects
 267      (lambda (obj type size)
 268        (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
 269        (incf (aref sizes type) size)
 270        (incf (aref counts type)))
 271      space)
 272
 273     (let ((totals (make-hash-table :test 'eq)))
 274       (dotimes (i 256)
 275         (let ((total-count (aref counts i)))
 276           (unless (zerop total-count)
 277             (let* ((total-size (aref sizes i))
 278                    (name (room-info-name (aref *room-info* i)))
 279                    (found (gethash name totals)))
 280               (cond (found
 281                      (incf (first found) total-size)
 282                      (incf (second found) total-count))
 283                     (t
 284                      (setf (gethash name totals)
 285                            (list total-size total-count name))))))))
 286
 287       (collect ((totals-list))
 288         (maphash (lambda (k v)
 289                    (declare (ignore k))
 290                    (totals-list v))
 291                  totals)
 292         (sort (totals-list) #'> :key #'first)))))
 293
 294 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
 295 ;;; (space-name . totals-for-space), where totals-for-space is the list
 296 ;;; returned by TYPE-BREAKDOWN.
 297 (defun print-summary (spaces totals)
 298   (let ((summary (make-hash-table :test 'eq)))
 299     (dolist (space-total totals)
 300       (dolist (total (cdr space-total))
 301         (push (cons (car space-total) total)
 302               (gethash (third total) summary))))
 303
 304     (collect ((summary-totals))
 305       (maphash (lambda (k v)
 306                  (declare (ignore k))
 307                  (let ((sum 0))
 308                    (declare (fixnum sum))
 309                    (dolist (space-total v)
 310                      (incf sum (first (cdr space-total))))
 311                    (summary-totals (cons sum v))))
 312                summary)
 313
 314       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
 315       (let ((summary-total-bytes 0)
 316             (summary-total-objects 0))
 317         (declare (fixnum summary-total-bytes summary-total-objects))
 318         (dolist (space-totals
 319                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
 320           (let ((total-objects 0)
 321                 (total-bytes 0)
 322                 name)
 323             (declare (fixnum total-objects total-bytes))
 324             (collect ((spaces))
 325               (dolist (space-total space-totals)
 326                 (let ((total (cdr space-total)))
 327                   (setq name (third total))
 328                   (incf total-bytes (first total))
 329                   (incf total-objects (second total))
 330                   (spaces (cons (car space-total) (first total)))))
 331               (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
 332                       name total-bytes total-objects)
 333               (dolist (space (spaces))
 334                 (format t ", ~W% ~(~A~)"
 335                         (round (* (cdr space) 100) total-bytes)
 336                         (car space)))
 337               (format t ".~%")
 338               (incf summary-total-bytes total-bytes)
 339               (incf summary-total-objects total-objects))))
 340         (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
 341                 summary-total-bytes summary-total-objects)))))
 342
 343 ;;; Report object usage for a single space.
 344 (defun report-space-total (space-total cutoff)
 345   (declare (list space-total) (type (or single-float null) cutoff))
 346   (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
 347   (let* ((types (cdr space-total))
 348          (total-bytes (reduce #'+ (mapcar #'first types)))
 349          (total-objects (reduce #'+ (mapcar #'second types)))
 350          (cutoff-point (if cutoff
 351                            (truncate (* (float total-bytes) cutoff))
 352                            0))
 353          (reported-bytes 0)
 354          (reported-objects 0))
 355     (declare (fixnum total-objects total-bytes cutoff-point reported-objects
 356                      reported-bytes))
 357     (loop for (bytes objects name) in types do
 358       (when (<= bytes cutoff-point)
 359         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
 360                 (- total-bytes reported-bytes)
 361                 (- total-objects reported-objects))
 362         (return))
 363       (incf reported-bytes bytes)
 364       (incf reported-objects objects)
 365       (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
 366               bytes objects name))
 367     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
 368             total-bytes total-objects (car space-total))))
 369
 370 ;;; Print information about the heap memory in use. PRINT-SPACES is a
 371 ;;; list of the spaces to print detailed information for.
 372 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
 373 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
 374 ;;; PRINT-SUMMARY is true, then summary information will be printed.
 375 ;;; The defaults print only summary information for dynamic space. If
 376 ;;; true, CUTOFF is a fraction of the usage in a report below which
 377 ;;; types will be combined as OTHER.
 378 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
 379                           (print-summary t) cutoff)
 380   (declare (type (or single-float null) cutoff))
 381   (let* ((spaces (if (eq count-spaces t)
 382                      '(:static :dynamic :read-only)
 383                      count-spaces))
 384          (totals (mapcar (lambda (space)
 385                            (cons space (type-breakdown space)))
 386                          spaces)))
 387
 388     (dolist (space-total totals)
 389       (when (or (eq print-spaces t)
 390                 (member (car space-total) print-spaces))
 391         (report-space-total space-total cutoff)))
 392
 393     (when print-summary (print-summary spaces totals)))
 394
 395   (values))
 396 \f
 397 ;;; Print info about how much code and no-ops there are in SPACE.
 398 (defun count-no-ops (space)
 399   (declare (type spaces space))
 400   (let ((code-words 0)
 401         (no-ops 0)
 402         (total-bytes 0))
 403     (declare (fixnum code-words no-ops)
 404              (type unsigned-byte total-bytes))
 405     (map-allocated-objects
 406      (lambda (obj type size)
 407        (declare (fixnum size) (optimize (safety 0)))
 408        (when (eql type code-header-widetag)
 409          (incf total-bytes size)
 410          (let ((words (truly-the fixnum (%code-code-size obj)))
 411                (sap (truly-the system-area-pointer
 412                                (%primitive code-instructions obj))))
 413            (incf code-words words)
 414            (dotimes (i words)
 415              (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
 416                (incf no-ops))))))
 417      space)
 418
 419     (format t
 420             "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
 421             total-bytes code-words no-ops
 422             (round (* no-ops 100) code-words)))
 423
 424   (values))
 425 \f
 426 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
 427   (let ((descriptor-words 0)
 428         (non-descriptor-headers 0)
 429         (non-descriptor-bytes 0))
 430     (declare (type unsigned-byte descriptor-words non-descriptor-headers
 431                    non-descriptor-bytes))
 432     (dolist (space (or spaces '(:read-only :static :dynamic)))
 433       (declare (inline map-allocated-objects))
 434       (map-allocated-objects
 435        (lambda (obj type size)
 436          (declare (fixnum size) (optimize (safety 0)))
 437          (case type
 438            (#.code-header-widetag
 439             (let ((inst-words (truly-the fixnum (%code-code-size obj))))
 440               (declare (type fixnum inst-words))
 441               (incf non-descriptor-bytes (* inst-words n-word-bytes))
 442               (incf descriptor-words
 443                     (- (truncate size n-word-bytes) inst-words))))
 444            ((#.bignum-widetag
 445              #.single-float-widetag
 446              #.double-float-widetag
 447              #.simple-base-string-widetag
 448              #.simple-array-nil-widetag
 449              #.simple-bit-vector-widetag
 450              #.simple-array-unsigned-byte-2-widetag
 451              #.simple-array-unsigned-byte-4-widetag
 452              #.simple-array-unsigned-byte-8-widetag
 453              #.simple-array-unsigned-byte-16-widetag
 454              #.simple-array-unsigned-byte-32-widetag
 455              #.simple-array-signed-byte-8-widetag
 456              #.simple-array-signed-byte-16-widetag
 457              #.simple-array-signed-byte-30-widetag
 458              #.simple-array-signed-byte-32-widetag
 459              #.simple-array-single-float-widetag
 460              #.simple-array-double-float-widetag
 461              #.simple-array-complex-single-float-widetag
 462              #.simple-array-complex-double-float-widetag)
 463             (incf non-descriptor-headers)
 464             (incf non-descriptor-bytes (- size n-word-bytes)))
 465            ((#.list-pointer-lowtag
 466              #.instance-pointer-lowtag
 467              #.ratio-widetag
 468              #.complex-widetag
 469              #.simple-array-widetag
 470              #.simple-vector-widetag
 471              #.complex-base-string-widetag
 472              #.complex-vector-nil-widetag
 473              #.complex-bit-vector-widetag
 474              #.complex-vector-widetag
 475              #.complex-array-widetag
 476              #.closure-header-widetag
 477              #.funcallable-instance-header-widetag
 478              #.value-cell-header-widetag
 479              #.symbol-header-widetag
 480              #.sap-widetag
 481              #.weak-pointer-widetag
 482              #.instance-header-widetag)
 483             (incf descriptor-words (truncate size n-word-bytes)))
 484            (t
 485             (error "bogus widetag: ~W" type))))
 486        space))
 487     (format t "~:D words allocated for descriptor objects.~%"
 488             descriptor-words)
 489     (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
 490             non-descriptor-bytes non-descriptor-headers)
 491     (values)))
 492 \f
 493 ;;; Print a breakdown by instance type of all the instances allocated
 494 ;;; in SPACE. If TOP-N is true, print only information for the the
 495 ;;; TOP-N types with largest usage.
 496 (defun instance-usage (space &key (top-n 15))
 497   (declare (type spaces space) (type (or fixnum null) top-n))
 498   (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
 499   (let ((totals (make-hash-table :test 'eq))
 500         (total-objects 0)
 501         (total-bytes 0))
 502     (declare (fixnum total-objects total-bytes))
 503     (map-allocated-objects
 504      (lambda (obj type size)
 505        (declare (fixnum size) (optimize (speed 3) (safety 0)))
 506        (when (eql type instance-header-widetag)
 507          (incf total-objects)
 508          (incf total-bytes size)
 509          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
 510                 (found (gethash classoid totals)))
 511            (cond (found
 512                   (incf (the fixnum (car found)))
 513                   (incf (the fixnum (cdr found)) size))
 514                  (t
 515                   (setf (gethash classoid totals) (cons 1 size)))))))
 516      space)
 517
 518     (collect ((totals-list))
 519       (maphash (lambda (classoid what)
 520                  (totals-list (cons (prin1-to-string
 521                                      (classoid-proper-name classoid))
 522                                     what)))
 523                totals)
 524       (let ((sorted (sort (totals-list) #'> :key #'cddr))
 525             (printed-bytes 0)
 526             (printed-objects 0))
 527         (declare (fixnum printed-bytes printed-objects))
 528         (dolist (what (if top-n
 529                           (subseq sorted 0 (min (length sorted) top-n))
 530                           sorted))
 531           (let ((bytes (cddr what))
 532                 (objects (cadr what)))
 533             (incf printed-bytes bytes)
 534             (incf printed-objects objects)
 535             (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
 536                     bytes objects)))
 537
 538         (let ((residual-objects (- total-objects printed-objects))
 539               (residual-bytes (- total-bytes printed-bytes)))
 540           (unless (zerop residual-objects)
 541             (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
 542                     residual-bytes residual-objects))))
 543
 544       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
 545               space total-bytes total-objects)))
 546
 547   (values))
 548 \f
 549 (defun find-holes (&rest spaces)
 550   (dolist (space (or spaces '(:read-only :static :dynamic)))
 551     (format t "In ~A space:~%" space)
 552     (let ((start-addr nil)
 553           (total-bytes 0))
 554       (declare (type (or null (unsigned-byte 32)) start-addr)
 555                (type (unsigned-byte 32) total-bytes))
 556       (map-allocated-objects
 557        (lambda (object typecode bytes)
 558          (declare (ignore typecode)
 559                   (type (unsigned-byte 32) bytes))
 560          (if (and (consp object)
 561                   (eql (car object) 0)
 562                   (eql (cdr object) 0))
 563              (if start-addr
 564                  (incf total-bytes bytes)
 565                  (setf start-addr (sb!di::get-lisp-obj-address object)
 566                        total-bytes bytes))
 567              (when start-addr
 568                (format t "~:D bytes at #X~X~%" total-bytes start-addr)
 569                (setf start-addr nil))))
 570        space)
 571       (when start-addr
 572         (format t "~:D bytes at #X~X~%" total-bytes start-addr))))
 573   (values))
 574 \f
 575 ;;;; PRINT-ALLOCATED-OBJECTS
 576
 577 (defun print-allocated-objects (space &key (percent 0) (pages 5)
 578                                       type larger smaller count
 579                                       (stream *standard-output*))
 580   (declare (type (integer 0 99) percent) (type index pages)
 581            (type stream stream) (type spaces space)
 582            (type (or index null) type larger smaller count))
 583   (multiple-value-bind (start-sap end-sap) (space-bounds space)
 584     (let* ((space-start (sap-int start-sap))
 585            (space-end (sap-int end-sap))
 586            (space-size (- space-end space-start))
 587            (pagesize (sb!sys:get-page-size))
 588            (start (+ space-start (round (* space-size percent) 100)))
 589            (printed-conses (make-hash-table :test 'eq))
 590            (pages-so-far 0)
 591            (count-so-far 0)
 592            (last-page 0))
 593       (declare (type (unsigned-byte 32) last-page start)
 594                (fixnum pages-so-far count-so-far pagesize))
 595       (labels ((note-conses (x)
 596                  (unless (or (atom x) (gethash x printed-conses))
 597                    (setf (gethash x printed-conses) t)
 598                    (note-conses (car x))
 599                    (note-conses (cdr x)))))
 600         (map-allocated-objects
 601          (lambda (obj obj-type size)
 602            (declare (optimize (safety 0)))
 603            (let ((addr (get-lisp-obj-address obj)))
 604              (when (>= addr start)
 605                (when (if count
 606                          (> count-so-far count)
 607                          (> pages-so-far pages))
 608                  (return-from print-allocated-objects (values)))
 609
 610                (unless count
 611                  (let ((this-page (* (the (values (unsigned-byte 32) t)
 612                                        (truncate addr pagesize))
 613                                      pagesize)))
 614                    (declare (type (unsigned-byte 32) this-page))
 615                    (when (/= this-page last-page)
 616                      (when (< pages-so-far pages)
 617                        ;; FIXME: What is this? (ERROR "Argh..")? or
 618                        ;; a warning? or code that can be removed
 619                        ;; once the system is stable? or what?
 620                        (format stream "~2&**** Page ~W, address ~X:~%"
 621                                pages-so-far addr))
 622                      (setq last-page this-page)
 623                      (incf pages-so-far))))
 624
 625                (when (and (or (not type) (eql obj-type type))
 626                           (or (not smaller) (<= size smaller))
 627                           (or (not larger) (>= size larger)))
 628                  (incf count-so-far)
 629                  (case type
 630                    (#.code-header-widetag
 631                     (let ((dinfo (%code-debug-info obj)))
 632                       (format stream "~&Code object: ~S~%"
 633                               (if dinfo
 634                                   (sb!c::compiled-debug-info-name dinfo)
 635                                   "No debug info."))))
 636                    (#.symbol-header-widetag
 637                     (format stream "~&~S~%" obj))
 638                    (#.list-pointer-lowtag
 639                     (unless (gethash obj printed-conses)
 640                       (note-conses obj)
 641                       (let ((*print-circle* t)
 642                             (*print-level* 5)
 643                             (*print-length* 10))
 644                         (format stream "~&~S~%" obj))))
 645                    (t
 646                     (fresh-line stream)
 647                     (let ((str (write-to-string obj :level 5 :length 10
 648                                                 :pretty nil)))
 649                       (unless (eql type instance-header-widetag)
 650                         (format stream "~S: " (type-of obj)))
 651                       (format stream "~A~%"
 652                               (subseq str 0 (min (length str) 60))))))))))
 653          space))))
 654   (values))
 655 \f
 656 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
 657
 658 (defvar *ignore-after* nil)
 659
 660 (defun maybe-cons (space x stuff)
 661   (if (or (not (eq space :dynamic))
 662           (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
 663       (cons x stuff)
 664       stuff))
 665
 666 (defun list-allocated-objects (space &key type larger smaller count
 667                                      test)
 668   (declare (type spaces space)
 669            (type (or index null) larger smaller type count)
 670            (type (or function null) test)
 671            (inline map-allocated-objects))
 672   (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
 673   (collect ((counted 0 1+))
 674     (let ((res ()))
 675       (map-allocated-objects
 676        (lambda (obj obj-type size)
 677          (declare (optimize (safety 0)))
 678          (when (and (or (not type) (eql obj-type type))
 679                     (or (not smaller) (<= size smaller))
 680                     (or (not larger) (>= size larger))
 681                     (or (not test) (funcall test obj)))
 682            (setq res (maybe-cons space obj res))
 683            (when (and count (>= (counted) count))
 684              (return-from list-allocated-objects res))))
 685        space)
 686       res)))
 687
 688 (defun list-referencing-objects (space object)
 689   (declare (type spaces space) (inline map-allocated-objects))
 690   (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
 691   (let ((res ()))
 692     (flet ((res (x)
 693              (setq res (maybe-cons space x res))))
 694       (map-allocated-objects
 695        (lambda (obj obj-type size)
 696          (declare (optimize (safety 0)) (ignore obj-type size))
 697          (typecase obj
 698            (cons
 699             (when (or (eq (car obj) object) (eq (cdr obj) object))
 700               (res obj)))
 701            (instance
 702             (dotimes (i (%instance-length obj))
 703               (when (eq (%instance-ref obj i) object)
 704                 (res obj)
 705                 (return))))
 706            (simple-vector
 707             (dotimes (i (length obj))
 708               (when (eq (svref obj i) object)
 709                 (res obj)
 710                 (return))))
 711            (symbol
 712             (when (or (eq (symbol-name obj) object)
 713                       (eq (symbol-package obj) object)
 714                       (eq (symbol-plist obj) object)
 715                       (eq (symbol-value obj) object))
 716               (res obj)))))
 717        space))
 718     res))