From 842f445cd941eaeb4341b0d7f6f1f9a60fa63479 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sun, 14 Apr 1991 16:49:54 +0000 Subject: [PATCH] Added PRINT-ALLOCATED-OBJECTS, for groveling around in memory to check VM locality. --- code/room.lisp | 66 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 63 insertions(+), 3 deletions(-) diff --git a/code/room.lisp b/code/room.lisp index cc799c0a0..4ca3e5427 100644 --- a/code/room.lisp +++ b/code/room.lisp @@ -7,18 +7,18 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.5 1991/04/09 14:20:10 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.6 1991/04/14 16:49:54 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.5 1991/04/09 14:20:10 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.6 1991/04/14 16:49:54 ram Exp $ ;;; ;;; Heap grovelling memory usage stuff. ;;; (in-package "VM") (use-package "SYSTEM") (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage - structure-usage find-holes)) + structure-usage find-holes print-allocated-objects)) (in-package "LISP") (import '( dynamic-0-space-start dynamic-1-space-start read-only-space-start @@ -542,3 +542,63 @@ (when start-addr (format t "~D bytes at #x~X~%" total-bytes start-addr)))) (values)) + + +;;; Print allocated objects: + +(defun pagesize () + (nth-value 1 (mach:vm_statistics system:*task-self*))) + +(defun print-allocated-objects (space &key (percent 0) (pages 5) + (stream *standard-output*)) + (declare (type (integer 0 99) percent) (type c::index pages) + (type stream stream) (type spaces space)) + (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 (pagesize)) + (start (+ space-start (round (* space-size percent) 100))) + (pages-so-far 0) + (last-page 0)) + (declare (type (unsigned-byte 32) last-page start) + (fixnum pages-so-far pagesize)) + (map-allocated-objects + #'(lambda (obj type size) + (declare (ignore size) (optimize (speed 3) (safety 0))) + (let ((addr (get-lisp-obj-address obj))) + (when (and (>= addr start) + (<= pages-so-far pages)) + (let ((this-page (* (the (unsigned-byte 32) + (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))) + + (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 + (write-char #\. stream)) + (t + (fresh-line stream) + (let ((str (write-to-string obj :level 5 :length 10 + :pretty nil))) + (unless (eql type structure-header-type) + (format stream "~S: " (type-of obj))) + (format stream "~A~%" + (subseq str 0 (min (length str) 60))))))))) + space))) + (values)) -- GitLab