;; -*- mode:emacs-lisp;coding:utf-8;lexical-binding:t -*-
;;;;**************************************************************************
;;;;FILE: room.el
;;;;LANGUAGE: emacs lisp
;;;;SYSTEM: POSIX
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Implement a room function for emacs lisp.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-12-06 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(require 'cl)
(require 'pjb-emacs)
(require 'pjb-strings)
(defstruct room-type-entry
type
(count 0)
(total-size 0))
(defstruct room-object-entry
object
(reference-count 1))
;; (pp(macroexpand '))
;; (progn
;; (defvar cl-struct-room-object-entry-tags)
;; (cl-defsubst room-object-entry-object #1=(cl-x)
;; (or #2=(and #4=(vectorp cl-x)
;; #5=(>=
;; (length cl-x)
;; 3)
;; #6=(memq
;; (aref cl-x 0)
;; cl-struct-room-object-entry-tags))
;; (error #3="%s accessing a non-%s" 'room-object-entry-object 'room-object-entry))
;; (aref cl-x 1))
;; (cl-defsubst room-object-entry-reference-count #1#
;; (or #2#
;; (error #3# 'room-object-entry-reference-count 'room-object-entry))
;; (aref cl-x 2))
;; (cl-defsubst room-object-entry-p
;; (cl-x)
;; (and #4# #5# #6# t))
;; (defun copy-room-object-entry
;; (x)
;; (copy-sequence x))
;; (cl-defsubst make-room-object-entry
;; (&cl-defs
;; '(nil . #7=((cl-tag-slot)
;; (object)
;; (reference-count 1)))
;; &key object reference-count)
;; (vector 'cl-struct-room-object-entry object reference-count))
;; (setq cl-struct-room-object-entry-tags
;; (list 'cl-struct-room-object-entry))
;; (cl-eval-when
;; (compile load eval)
;; (put 'room-object-entry 'cl-struct-slots '#7#)
;; (put 'room-object-entry 'cl-struct-type
;; '(vector nil))
;; (put 'room-object-entry 'cl-struct-include 'nil)
;; (put 'room-object-entry 'cl-struct-print t)
;; (put 'make-room-object-entry #8='side-effect-free 't)
;; (put 'copy-room-object-entry #8# 't)
;; (put 'room-object-entry-p #8# 'error-free)
;; (put 'room-object-entry-reference-count #8# 't)
;; (put 'room-object-entry-object #8# 't))
;; 'room-object-entry)
(defparameter *emacs-lisp-types*
'(symbol
integer string cons marker overlay float
window-configuration process window subr compiled-function buffer
char-table bool-vector frame hash-table font-spec font-entity font-object
vector))
(defconstant +word-size+ (if (< most-positive-fixnum 4294967296.0)
4 ; bytes
8))
(defun type-size (type)
(ecase type
(float (* 1 +word-size+))
(integer (* 1 +word-size+))
(cons (* 2 +word-size+))
(marker (* 2 +word-size+))
(symbol (* 4 +word-size+))
(overlay 'unknown)
(window-configuration 'unknown)
(process 'unknown)
(window 'unknown)
(frame 'unknown)
(font-spec 'unknown)
(font-entity 'unknown)
(font-object 'unknown)
(string 'variable)
(subr 'variable)
(compiled-function 'variable)
(buffer 'variable)
(char-table 'variable)
(bool-vector 'variable)
(hash-table 'variable)
(vector (let ((slots (get type 'cl-struct-slots)))
(if slots
(length slots)
'variable)))))
(defun object-size (object)
(let ((size (type-size (type-of object))))
(cond
((integerp size)
size)
((eq 'unknown size)
1)
(t
(* +word-size+
(ceiling
(typecase object
(string (+ (* 1 +word-size+) (length object)))
(vector (+ (* 1 +word-size+) (* +word-size+ (length object))))
(bool-vector (+ (* 1 +word-size+) (* (/ +word-size+ 8) (length object))))
(hash-table (+ (* 4 +word-size+) (* 2 +word-size+ (hash-table-size object))))
(buffer (+ (* 32 +word-size+) (length (buffer-name object)) (buffer-size object)))
(t 1))
+word-size+))))))
(defun structure-type-p (symbol)
(and (symbolp symbol)
(prefixp "cl-struct-" (symbol-name symbol))))
(defun structure-predicate (symbol)
(if (structure-type-p symbol)
(let ((predicate (intern (concat (subseq (symbol-name symbol) 10) "-p"))))
(if (fboundp predicate)
predicate
(constantly nil)))
(constantly nil)))
(defun structurep (object)
(and (vectorp object)
(plusp (length object))
(symbolp (aref object 0))
(funcall (structure-predicate (aref object 0)) object)
(intern (subseq (symbol-name (aref object 0)) 10))))
;; (structurep (make-room-object-entry))
;; room-object-entry
;;
;; (structurep [cl-struct-room-object-entry nil])
;; nil
;;
;; (structurep [cl-struct-XYZ nil 1 2 3])
;; nil
(put 'cl-labels 'lisp-indent-function '((&whole 4 &rest (&whole 1 &lambda &body)) &body))
(put 'cl-flet 'lisp-indent-function '((&whole 4 &rest (&whole 1 &lambda &body)) &body))
(defun room ()
"Returns a description of the memory use."
(let ((all-objects (make-hash-table :size 100000))
(all-types (make-hash-table :size 100)))
(dolist (type *emacs-lisp-types*)
(setf (gethash type all-types) (make-room-type-entry :type type)))
(cl-labels ((walk-root (first-object)
(loop
with objects = (list first-object)
for object = (pop objects)
do (cl-flet ((walk (object) (push object objects)))
(let ((entry (gethash object all-objects)))
(if entry
(incf (room-object-entry-reference-count entry))
(progn
(setf (gethash object all-objects) (make-room-object-entry :object object))
(let* ((type (or (structurep object) (type-of object)))
(tentry (gethash type all-types)))
(unless tentry
(setf tentry (setf (gethash type all-types) (make-room-type-entry :type type))))
(incf (room-type-entry-count tentry))
(incf (room-type-entry-total-size tentry) (object-size object)))
(ecase (type-of object)
((integer))
((float))
((string) ; properties?
)
((marker)
(walk (marker-buffer object))
(walk (marker-insertion-type object))
(walk (marker-position object)))
((cons)
(walk (car object))
(walk (cdr object)))
((overlay))
((window-configuration))
((process))
((window))
((subr))
((compiled-function))
((buffer)
(walk (buffer-name object))
(walk (buffer-file-name object))
(walk (buffer-base-buffer object)))
((char-table))
((bool-vector))
((frame) (walk (frame-buffer-list object))
(walk (frame-parameters object))
(walk (frame-title object))
;; …
)
((hash-table) (maphash (lambda (k v)
(walk k)
(walk v)) object)
(walk (hash-table-test object)))
((font-spec))
((font-entity))
((font-object))
((vector) (map nil (function walk) object))
((symbol) (when (fboundp object)
(walk (symbol-function object)))
(when (boundp object)
(walk (symbol-value object)))
(walk (symbol-plist object))
(dolist (buffer (buffer-list))
(walk (symbol-value-in-buffer 'x buffer)))))))))
while objects)))
(map nil (function walk-root) (frame-list))
(map nil (function walk-root) (buffer-list))
(do-symbols (symbol) (walk-root symbol))
(let ((results '()))
(maphash (lambda (type entry)
(declare (ignore type))
(push (list (room-type-entry-type entry)
(room-type-entry-count entry)
(room-type-entry-total-size entry)) results))
all-types)
results))))
;; (load (progn (byte-compile-file "room.el") "room.elc"))
;; (room)
;; ((room-type-entry 21 840)
;; (room-object-entry 83 2656)
;; (slime-test 58 4176)
;; (isearch--state 15 1680)
;; (ftree 695 22240)
;; (fo-cache 1 56)
;; (ossn 4096 360448)
;; (lambda-list 752 72192)
;; (slime-contrib 20 1440)
;; (slime-repl-shortcut 26 1248)
;; (palette 37 2368)
;; (lisp-implementation 8 704)
;; (vector 10082 676720)
;; (font-object 0 0)
;; (font-entity 0 0)
;; (font-spec 0 0)
;; (hash-table 25 1673056)
;; (frame 1 1)
;; (bool-vector 0 0)
;; (char-table 137 1096)
;; (buffer 25 2916080)
;; (compiled-function 14859 118872)
;; (subr 1105 8840)
;; (window 3 3)
;; (process 1 1)
;; (window-configuration 0 0)
;; (float 304 2432)
;; (overlay 11 11)
;; (marker 57 912)
;; (cons 655489 10487824)
;; (string 67635 2927056)
;; (integer 23823 190584)
;; (symbol 58332 1866624))