Copy of https://people.gnome.org/~xan/memory.lisp

memory.lisp

;;;; memory.lisp

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

;;; Utility functions to measure memory consumption in SBCL
;;; With lots of code and ideas from David Lichteblau's graph.lisp and
;;; object-size.lisp from darcsweb.

;; Some useful links:
;; - http://sbcl-internals.cliki.net/tag%20bit
;;   Explanation of lowtags and widetags
;; - http://coding.derkeiler.com/Archive/Lisp/comp.lang.lisp/2006-05/msg00863.html
;;   About FDEFN

(defpackage #:memory
  (:use #:cl))

(in-package #:memory)

(defconstant +n+ sb-vm:n-word-bytes
  "The number of bytes in a word.")

(defun native-address (object)
  "The address of the object without the lowtag bits"
  (logandc2 (sb-kernel:get-lisp-obj-address object)
            sb-vm:lowtag-mask))

(defun native-pointer (object)
  (sb-sys:int-sap (native-address object)))

(defun object-ref-lispobj (object index)
  (sb-sys:without-gcing
    (sb-kernel:make-lisp-obj
     (sb-sys:sap-ref-word (native-pointer object) (* index +n+)))))

(defun recurse-descendant-objects (object function)
  "Goes through OBJECT and all its descendants calling FUNCTION on
  each one."
  (let ((seen-objects (make-hash-table)))
    (labels ((recurse (object)
               
               (when (or (typep object 'sb-kernel:layout)
                         (typep object 'sb-impl::unix-host)
                         (eq object 'eq)
                         (typep object 'SB-THREAD:MUTEX)
                         (typep object 'sb-pcl::wrapper))
                 (return-from recurse))

               (unless (or 
                         (gethash object seen-objects)
                         (find object *seen-objects*))
                 (setf (gethash object seen-objects) t)
                 (funcall function object)
                 (typecase object
                   ((or number string character sb-sys:system-area-pointer)
                    (values))
                   (symbol
                    (recurse (symbol-name object))
                    (recurse (symbol-plist object))
                    (when (boundp object)
                      (recurse (symbol-value object)))
                    (when (fboundp object)
                      (recurse (symbol-function object))))
                   (cons
                    (recurse (car object))
                    (recurse (cdr object)))
                   (sb-kernel:funcallable-instance
                    (loop
                       for i from 1 to (sb-kernel:get-closure-length object) do
                       (recurse (object-ref-lispobj object i))))
                   (sb-kernel:instance
                    (let* ((len (sb-kernel:%instance-length object))
                           (layout (sb-kernel:%instance-layout object))
                           (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
                      (loop
                         for i from 0 below (- len nuntagged) do
                         (recurse (sb-kernel:%instance-ref object i)))))
                   (function
                    (let ((widetag (sb-kernel:widetag-of object)))
                      (cond ((= widetag sb-vm:simple-fun-header-widetag)
                             (recurse (sb-kernel:fun-code-header object)))
                            ((= widetag sb-vm:closure-header-widetag)
                             (let ((len (sb-kernel:get-closure-length object)))
                               (recurse (sb-kernel:%closure-fun object))
                               ;; from 2 BELOW or TO? TO seems to bork
                               (loop for i from 2 below len do
                                    (recurse (object-ref-lispobj object i)))))
                            (t
                             (error "Unknown function object")))))
                   ;; Meh...
                   (simple-vector
                     ; TODO: here we loosing some bytes but recursion works ok
                     (when (or 
                             (zerop (array-total-size object))
                             (not (typep (aref object 0) 'SB-C:DEFINITION-SOURCE-LOCATION)))
                       (recurse (coerce object 'list))))
                   (array
                    (dotimes (i (apply #'* (array-dimensions object)))
                      (recurse (row-major-aref object i))))
                   ;; Mmmm...
                   (sb-vm::code-component
                     ; XXX it looses some bytes but avoids unnecessary recursion
                     (recurse object)
                     #+l(let ((length (sb-kernel:get-header-data object)))
                      (do ((i sb-vm::code-constants-offset (1+ i)))
                          ((= i length))
                        (recurse (sb-vm::code-header-ref object i)))))
                   (sb-kernel:fdefn
                    (recurse (sb-kernel:fdefn-name object))
                    (recurse (sb-kernel:fdefn-fun object)))
                   ;; Here be dragons
                   (sb-ext:weak-pointer
                    (multiple-value-bind (value alive)
                        (sb-ext:weak-pointer-value object)
                      (when alive
                        (recurse value))))
                   (sb-kernel::random-class
                    ;; FIXME: no clue what to do here
                    )
                   (t
                    (warn "Unknown type ~s" (type-of object)))))))
      (recurse object))))

(defun immediate-p (object)
  "Whether or not OBJECT is immediate, ie, do not use any memory (?)"
  (or (null object)
      (eq object t)
      (evenp (sb-kernel:lowtag-of object))))

(defun calculate-allocated-memory (object)
  "Returns the memory allocated in the heap by OBJECT."
  (if (immediate-p object)
      0
      (typecase object
        ((or integer single-float double-float (complex single-float)
             (complex double-float) #+long-float (complex long-float)
             sb-sys:system-area-pointer sb-kernel:fdefn)
         (* (1+ (sb-kernel:get-header-data object)) +n+))
        (cons
         (* 2 +n+))
        (symbol
         (* sb-vm:symbol-size +n+))
        (simple-vector
         (* (+ 2 (length object)) +n+))
        ((simple-array * (*))
         (align (* +n+ (size-of object))))
        (array
         (+ +n+ (* (array-total-size object)
                   +n+)))
        (function
         (if (or (eql (type-of object)
                      'sb-kernel:funcallable-instance)
                 (= (sb-kernel:widetag-of object)
                    sb-vm:closure-header-widetag))
             (* (1+ (sb-kernel:get-closure-length object)) +n+)
             0))
        (sb-kernel:instance
         (* (1+ (sb-kernel:%instance-length object)) +n+))
        (sb-vm::code-component 
          (+ (sb-kernel:%code-code-size object)
             (* (sb-kernel:get-header-data object) sb-vm:n-word-bytes)))
        (t
         0))))

(defparameter *context* nil
  "Context to store progress in current execution.")

(defstruct
    (context (:constructor make-context (stream)))
  stream
  (length 0)
  (unknown 0)
  (details nil))

(defun calculate-and-store-memory (object)
  (let ((m (calculate-allocated-memory object)))
    (incf (context-length *context*) m)))

(defvar *seen-objects* nil)

(defun list->hash-table (list)
  (let ((hash (make-hash-table)))
    (loop for i in list do
          (setf (gethash i hash) t))
    hash))

(defun dump-memory (object &key (stream t) skip-objects)
  "Calculates the memory used by OBJECT."
  (let ((*context* (make-context stream))
        (*seen-objects* skip-objects #+l(list->hash-table skip-objects)))
    (recurse-descendant-objects object #'calculate-and-store-memory)
    (report-memory *context* :verbosity :min)))

(defun sanitize-bytes-value (value)
  (cond
    ((< value 1000)
     (format nil "~f bytes" value))
    ((< value 1000000)
     (format nil "~f KB" (/ value 1000)))
    ((< value 1000000000)
     (format nil "~f MB" (/ value 1000000)))
    (t
     (format nil "~f GB" (/ value 1000000000)))))

(defun report-memory (context &key (verbosity :default))
  (let ((total (reduce #'+ (context-details context) :key #'cdr)))
    (ccase verbosity
      (:min
       (format t "Total memory used: ~a~%" (sanitize-bytes-value (context-length context))))
      (:default
       (let ((details (context-details context)))
         (dolist (detail details)
           (format t "Memory for type ~a: ~a~%" (car detail) (cdr detail)))
         (format t "~%Total memory used: ~a~%" total))))))

(sb-alien:define-alien-variable "sizetab" (array (* t) 256))

(defun align (address)
  (- address (nth-value 1 (ceiling address (1+ sb-vm:lowtag-mask)))))

(defun size-of (object)
  (sb-sys:with-pinned-objects (object)
    (sb-alien:with-alien
        ((fn (* (function sb-alien:long (* t)))
             (sb-sys:sap-ref-sap (sb-alien:alien-sap sizetab)
                                 (* +n+ (sb-kernel:widetag-of object)))))
      (sb-alien:alien-funcall fn (native-pointer object)))))