add memory.lisp
This commit is contained in:
parent
9dfcb2da9b
commit
60b0609c86
1 changed files with 218 additions and 0 deletions
218
test/memory.lisp
Normal file
218
test/memory.lisp
Normal file
|
|
@ -0,0 +1,218 @@
|
|||
;;;; 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)
|
||||
(unless (gethash 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
|
||||
(recurse (coerce object 'list)))
|
||||
(array
|
||||
(dotimes (i (apply #'* (array-dimensions object)))
|
||||
(recurse (row-major-aref object i))))
|
||||
;; Mmmm...
|
||||
(sb-vm::code-component
|
||||
(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+))
|
||||
(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)))
|
||||
|
||||
(defun dump-memory (object &key (stream t))
|
||||
"Calculates the memory used by OBJECT."
|
||||
(let ((*context* (make-context stream)))
|
||||
(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)))))
|
||||
|
||||
Loading…
Add table
Reference in a new issue