From 09f93326354c1ad87ecf9bfbd7adda2e825ffd20 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 1 Mar 1993 18:48:40 +0000
Subject: [PATCH] Initial revision

---
 tools/heapanal.lisp | 504 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 504 insertions(+)
 create mode 100644 tools/heapanal.lisp

diff --git a/tools/heapanal.lisp b/tools/heapanal.lisp
new file mode 100644
index 000000000..16a84951a
--- /dev/null
+++ b/tools/heapanal.lisp
@@ -0,0 +1,504 @@
+;;; -*- Package: HEAPANAL -*-
+
+(in-package "HEAPANAL")
+(use-package "SYSTEM")
+(use-package "EXT")
+(use-package "MACH")
+(use-package "ALIEN")
+(use-package "C-CALL")
+
+
+;;;; MACH primitives we need.
+
+(def-alien-routine ("vm_read" vm_read) int
+  (task port)
+  (address unsigned-long)
+  (size unsigned-long)
+  (data system-area-pointer :out)
+  (data-size unsigned-long :out))
+
+(def-alien-routine ("task_by_unix_pid" task_by_unix_pid) int
+  (task port)
+  (pid unsigned-long)
+  (result port :out))
+
+
+
+;;;; Data structures for holding the info.
+
+(defstruct (heap-info
+	    (:constructor make-heap-info (pid))
+	    (:print-function %print-heap-info))
+  ;;
+  ;; The UNIX pid for the task we are interested in.
+  (pid (required-argument))
+  ;;
+  ;; The MACH port for the task.
+  (task (gr-call* task_by_unix_pid *task-self* pid))
+  ;;
+  ;; Cache used by read-heap.
+  (prev-addr nil :type (or null (unsigned-byte 32)))
+  (prev-sap nil :type (or null system-area-pointer))
+  ;;
+  ;; Symbol table used by the task, or NIL if it's the same as ours.
+  (symbol-table nil :type (or null hash-table))
+  ;;
+  ;; The range of dynamic space, so we can tell dynamic pointers.
+  (dynamic-start nil :type (or null (unsigned-byte 32)))
+  (dynamic-end nil :type (or null (unsigned-byte 32)))
+  ;;
+  ;; Hash table mapping addresses to objects.
+  (objects (make-hash-table :test #'equal :size 1000 :rehash-size 1000))
+  ;;
+  ;; Queue of ungroveled objects.  Objects are added at the head, and poped
+  ;; from the tail.
+  (queue-head nil :type list)
+  (queue-tail nil :type list))
+
+(defun %print-heap-info (info stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (info stream :type t :identity t)
+    (format stream "for pid ~D" (heap-info-pid info))))
+
+(defstruct (object
+	    (:print-function %print-object)
+	    (:constructor make-object (address)))
+  ;;
+  ;; The address this object lives at.
+  (address (required-argument) :type (unsigned-byte 32))
+  ;;
+  ;; List of references to this object.  Each entry is either an object,
+  ;; or an ub-32 stack address.
+  (references nil :type list))
+
+(defun %print-object (object stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (object stream :type t)
+    (format stream "#x~8,'0X" (object-address object))))
+
+
+
+;;;; Interface to importing stuff.
+
+(defparameter page-size (get-page-size))
+
+(defun read-heap (info address)
+  (declare (type heap-info info))
+  (multiple-value-bind (page offset) (truncate address page-size)
+    (let ((address (* page page-size)))
+      (cond
+       ((and (heap-info-prev-addr info)
+	     (= (heap-info-prev-addr info) address))
+	(values (sap+ (heap-info-prev-sap info) offset)
+		(- (* page-size 2) offset)))
+       (t
+	(when (heap-info-prev-sap info)
+	  (gr-call vm_deallocate *task-self* (heap-info-prev-sap info)
+		   (* page-size 2))
+	  (setf (heap-info-prev-addr info) nil)
+	  (setf (heap-info-prev-sap info) nil))
+	(gr-bind (base size)
+		 (vm_read (heap-info-task info) address (* page-size 2))
+	  (declare (ignore size))
+	  (setf (heap-info-prev-addr info) address)
+	  (setf (heap-info-prev-sap info) base)
+	  (values (sap+ base offset)
+		  (- (* page-size 2) offset))))))))
+
+
+;;;; Symbol table interface.
+
+(defun load-symbol-table (info pathname)
+  (with-open-file (stream pathname)
+    (setf (heap-info-symbol-table info) (make-hash-table :test #'equal))
+    ))
+
+(defun extract-foreign-symbol-value (info name)
+  (let ((sym-tab (heap-info-symbol-table info)))
+    (sap-ref-32 (read-heap info
+			   (if sym-tab
+			       (or (gethash name sym-tab)
+				   (error "Unknown foreign symbol: ~S" name))
+			       (sap-int (foreign-symbol-address name))))
+		0)))
+
+
+
+;;;; Utilities.
+
+(defun find-object (info addr &optional create)
+  (let ((object (gethash addr (heap-info-objects info))))
+    (when (and (null object) create)
+      (setf object (make-object addr))
+      (let ((new (list object)))
+	(if (heap-info-queue-head info)
+	    (setf (cdr (heap-info-queue-head info)) new
+		  (heap-info-queue-head info) new)
+	    (setf (heap-info-queue-head info) new
+		  (heap-info-queue-tail info) new)))
+      (setf (gethash addr (heap-info-objects info)) object))
+    object))
+
+(defun next-object (info)
+  (let ((tail (heap-info-queue-tail info)))
+    (when tail
+      (let ((result (pop tail)))
+	(setf (heap-info-queue-tail info) tail)
+	(unless tail
+	  (setf (heap-info-queue-head info) nil))
+	result))))
+
+(declaim (inline dynamic-pointer-p))
+(defun dynamic-pointer-p (info ptr)
+  (and (logbitp 0 ptr)
+       (<= (heap-info-dynamic-start info) ptr)
+       (< ptr (heap-info-dynamic-end info))))
+
+
+;;;; 
+
+(defun grovel-stack (info start end)
+  (let ((addr start))
+    (loop
+      (when (>= addr end)
+	(return))
+      (multiple-value-bind (sap bytes) (read-heap info addr)
+	(let ((count (min bytes (- end addr))))
+	  (dotimes (index (floor count 4))
+	    (let ((value (sap-ref-32 sap (* index 4))))
+	      (when (dynamic-pointer-p info value)
+		(push (+ addr (* index 4))
+		      (object-references (find-object info value t))))))
+	  (incf addr count))))))
+
+(defun grovel-control-stack (info)
+  (format t "Groveling control stack...~%")
+  (grovel-stack
+   info
+   (extract-foreign-symbol-value info "control_stack")
+   (extract-foreign-symbol-value info "current_control_stack_pointer")))
+
+(defun grovel-binding-stack (info)
+  (format t "Groveling binding stack...~%")
+  (grovel-stack
+   info
+   (extract-foreign-symbol-value info "binding_stack")
+   (extract-foreign-symbol-value info "current_binding_stack_pointer")))
+
+(defun grovel-object (info object)
+  (let* ((orig-addr (object-address object))
+	 (lowtag (logand orig-addr vm:lowtag-mask))
+	 (address (- orig-addr lowtag)))
+    (multiple-value-bind
+	(sap available)
+	(read-heap info address)
+      (multiple-value-bind
+	  (words words-to-grovel)
+	  (ecase lowtag
+	    (#.vm:list-pointer-type
+	     (values 2 2))
+	    (#.vm:instance-pointer-type
+	     (let* ((header (sap-ref-32 sap 0))
+		    (length (1+ (ash header (- vm:type-bits)))))
+	       (values length length)))
+	    (#.vm:other-pointer-type
+	     (let* ((header (sap-ref-32 sap 0))
+		    (type (logand header vm:type-mask)))
+	       (flet ((vector-len (bits-per-element &optional (extra 0))
+			(+ (ceiling (* (+ (ash (sap-ref-32
+						sap
+						(* vm:vector-length-slot 4))
+					       -2)
+					  extra)
+				       bits-per-element)
+				    vm:word-bits)
+			   vm:vector-data-offset)))
+		 (declare (inline vector-len))
+		 (ecase type
+		   ((#.vm:bignum-type
+		     #.vm:single-float-type
+		     #.vm:double-float-type
+		     #.vm:sap-type)
+		    (values (1+ (ash header (- vm:type-bits))) 0))
+		   ((#.vm:ratio-type
+		     #.vm:complex-type
+		     #.vm:simple-array-type
+		     #.vm:complex-string-type
+		     #.vm:complex-bit-vector-type
+		     #.vm:complex-vector-type
+		     #.vm:complex-array-type
+		     #.vm:value-cell-header-type
+		     #.vm:symbol-header-type
+		     #.vm:weak-pointer-type
+		     #.vm:fdefn-type)
+		    (let ((length (1+ (ash header (- vm:type-bits)))))
+		      (values length length)))
+		   (#.vm:simple-string-type
+		    (values (vector-len 8 1) 0))
+		   (#.vm:simple-bit-vector-type
+		    (values (vector-len 1) 0))
+		   (#.vm:simple-array-unsigned-byte-2-type
+		    (values (vector-len 2) 0))
+		   (#.vm:simple-array-unsigned-byte-4-type
+		    (values (vector-len 4) 0))
+		   (#.vm:simple-array-unsigned-byte-8-type
+		    (values (vector-len 8) 0))
+		   (#.vm:simple-array-unsigned-byte-16-type
+		    (values (vector-len 16) 0))
+		   ((#.vm:simple-array-unsigned-byte-32-type
+		     #.vm:simple-array-single-float-type)
+		    (values (vector-len 32) 0))
+		   (#.vm:simple-array-double-float-type
+		    (values (vector-len 64) 0))
+		   (#.vm:simple-vector-type
+		    (let ((length (vector-len 32)))
+		      (values length length)))
+		   (#.vm:code-header-type
+		    (values
+		     (ash (sap-ref-32 sap (* vm:code-code-size-slot 8)) -2)
+		     (ash header (- vm:type-bits))))
+		   (#.vm:return-pc-header-type
+		    (push object
+			  (object-references
+			   (find-object info
+					(- orig-addr
+					   (* (ash header (- vm:type-bits)) 4))
+					t)))
+		    (values 2 0))))))
+	    (#.vm:function-pointer-type
+	     (let* ((header (sap-ref-32 sap 0))
+		    (type (logand header vm:type-mask)))
+	       (ecase type
+		 ((#.vm:closure-header-type
+		   #.vm:funcallable-instance-header-type)
+		  (let ((length (1+ (ash header (- vm:type-bits)))))
+		    (values length length)))
+		 ((#.vm:function-header-type
+		   #.vm:closure-function-header-type)
+		  (push object
+			(object-references
+			 (find-object
+			  info
+			  (+ (- address
+				(* (ash header (- vm:type-bits)) 4))
+			     vm:other-pointer-type)
+			  t)))
+		  (values vm:function-code-offset
+			  vm:function-code-offset))))))
+	(unless (zerop words-to-grovel)
+	  (loop
+	    (let ((count (min (floor available 4) words-to-grovel)))
+	      (dotimes (i count)
+		(let ((value (sap-ref-32 sap (* i 4))))
+		  (when (dynamic-pointer-p info value)
+		    (push object
+			  (object-references (find-object info value t))))))
+	      (decf words-to-grovel count)
+	      (when (<= words-to-grovel 0)
+		(return))
+	      (incf address (* count 4))
+	      (multiple-value-setq (sap available) (read-heap info address)))))
+	words))))
+
+(defun grovel-static-space (info)
+  (format t "Groveling static space")
+  (force-output)
+  (let ((addr
+	 (extract-foreign-symbol-value info "static_space"))
+	(end
+	 (sap-ref-32 (read-heap info
+				(logandc2 (kernel:get-lisp-obj-address
+					   'lisp::*static-space-free-pointer*)
+					  vm:lowtag-mask))
+		     (* vm:symbol-value-slot 4)))
+	(count 0))
+    (loop
+      (when (>= addr end)
+	(return))
+      (incf count)
+      (when (>= count 1000)
+	(write-char #\.)
+	(force-output)
+	(setf count 0))
+      (let* ((header (sap-ref-32 (read-heap info addr) 0))
+	     (object
+	      (if (= (logand header 3) 2)
+		  ;; There is an other-immedate there, maybe it's a header.
+		  (let ((type (logand header vm:type-mask)))
+		    (cond ((= type vm:instance-header-type)
+			   (logior addr vm:instance-pointer-type))
+			  ((<= type vm:code-header-type)
+			   (logior addr vm:other-pointer-type))
+			  ((<= type vm:closure-function-header-type)
+			   (logior addr vm:function-pointer-type))
+			  ((or (= type vm:base-char-type)
+			       (= type vm:unbound-marker-type))
+			   ;; Assume we've got a cons pointing to it.
+			   (logior addr vm:list-pointer-type))
+			  (t
+			   (logior addr vm:other-pointer-type))))
+		  ;; It doesn't point to a header, so assume it's a cons cell.
+		  (logior addr vm:list-pointer-type)))
+	     (words (grovel-object info (make-object object))))
+	(incf addr (ash (ash (1+ words) -1) 3))))))
+
+(defun grovel-objects (info)
+  (format t "~&Groveling dynamic space")
+  (let ((count 0))
+    (loop
+      (incf count)
+      (when (>= count 1000)
+	(write-char #\.)
+	(force-output)
+	(setf count 0))
+      (let ((object (next-object info)))
+	(if object
+	    (grovel-object info object)
+	    (return))))))
+
+(defun grovel-heap (pid &key symbol-table)
+  (let ((info (make-heap-info pid)))
+    (when symbol-table
+      (load-symbol-table info symbol-table))
+    (setf (heap-info-dynamic-start info)
+	  (extract-foreign-symbol-value info "current_dynamic_space"))
+    (setf (heap-info-dynamic-end info)
+	  (extract-foreign-symbol-value info
+					"current_dynamic_space_free_pointer"))
+    (grovel-control-stack info)
+    (grovel-binding-stack info)
+    (grovel-static-space info)
+    (grovel-objects info)
+    info))
+
+(defun find-instances-of-type (info type-address)
+  (let ((results nil))
+    (maphash #'(lambda (key object)
+		 (declare (ignore key))
+		 (let ((address (object-address object)))
+		   (when (and (= (logand address vm:lowtag-mask)
+				 vm:instance-pointer-type)
+			      (= (sap-ref-32
+				  (read-heap info
+					     (- address 
+						vm:instance-pointer-type))
+				  4)
+				 type-address))
+		     (push object results))))
+	     (heap-info-objects info))
+    results))
+
+(defun find-roots-for (info address)
+  (let ((object (find-object info address)))
+    (unless object
+      (error "#x~8,'0X does not appear to be reachable in ~S" address info))
+    (let ((queue (list (list object)))
+	  (depth 0))
+      (loop
+	(let ((list queue)
+	      (any-results nil))
+	  (setf queue nil)
+	  (format t "Searching at depth ~D~%" depth)
+	  (dolist (entry list)
+	    (let ((object (car entry)))
+	      (cond ((and (object-p object)
+			  (dynamic-pointer-p info (object-address object)))
+		     (dolist (reference (object-references object))
+		       (unless (member reference entry)
+			 (push (cons reference entry) queue))))
+		    (t
+		     (unless any-results
+		       (terpri))
+		     (setf any-results t)
+		     (describe-path info entry)))))
+	  (unless queue
+	    (return))
+	  (when any-results
+	    (return))
+	  (incf depth)))))
+  nil)
+
+(defun describe-path (info path)
+  (dolist (object path)
+    (describe-object info object))
+  (terpri))
+
+(defun extract-symbol-name (info address)
+  (let* ((pname-addr (sap-ref-32 (read-heap info
+					    (- address
+					       vm:other-pointer-type))
+				 (* vm:symbol-name-slot 4)))
+	 (sap (read-heap info (- pname-addr vm:other-pointer-type)))
+	 (len (ash (sap-ref-32 sap 1) -2))
+	 (result (make-string len)))
+    (dotimes (i len)
+      (setf (schar result i)
+	    (code-char (sap-ref-8 sap
+				  (+ i
+				     (* vm:vector-data-offset
+					vm:word-bytes))))))
+    result))
+
+(defun describe-object (info object)
+  (if (object-p object)
+      (let* ((orig-addr (object-address object))
+	     (lowtag (logand orig-addr vm:lowtag-mask))
+	     (addr (- orig-addr lowtag)))
+	(ecase lowtag
+	  (#.vm:list-pointer-type
+	   (format t "Cons cell #x~8,'0X~%" orig-addr))
+	  (#.vm:instance-pointer-type
+	   (format t "Instance ~A at #x~8,'0X~%"
+		   (extract-symbol-name info
+					(sap-ref-32 (read-heap info addr) 4))
+		   orig-addr))
+	  ((#.vm:other-pointer-type
+	    #.vm:function-pointer-type)
+	   (let ((header (sap-ref-32 (read-heap info addr) 0)))
+	     (format t "~A at #x~8,'0X~%"
+		     (ecase (logand header vm:type-mask)
+		       (#.vm:symbol-header-type
+			(format nil "Symbol ~A"
+				(extract-symbol-name info orig-addr)))
+		       (#.vm:bignum-type "bignum")
+		       (#.vm:ratio-type "ratio")
+		       (#.vm:single-float-type "single-float")
+		       (#.vm:double-float-type "double-float")
+		       (#.vm:complex-type "complex")
+		       (#.vm:simple-array-type "simple-array")
+		       (#.vm:simple-string-type "simple-string")
+		       (#.vm:simple-bit-vector-type "simple-bit-vector")
+		       (#.vm:simple-vector-type "simple-vector")
+		       (#.vm:simple-array-unsigned-byte-2-type
+			"simple-array-unsigned-byte-2")
+		       (#.vm:simple-array-unsigned-byte-4-type
+			"simple-array-unsigned-byte-4")
+		       (#.vm:simple-array-unsigned-byte-8-type
+			"simple-array-unsigned-byte-8")
+		       (#.vm:simple-array-unsigned-byte-16-type
+			"simple-array-unsigned-byte-16")
+		       (#.vm:simple-array-unsigned-byte-32-type
+			"simple-array-unsigned-byte-32")
+		       (#.vm:simple-array-single-float-type
+			"simple-array-single-float")
+		       (#.vm:simple-array-double-float-type
+			"simple-array-double-float")
+		       (#.vm:complex-string-type "complex-string")
+		       (#.vm:complex-bit-vector-type "complex-bit-vector")
+		       (#.vm:complex-vector-type "complex-vector")
+		       (#.vm:complex-array-type "complex-array")
+		       (#.vm:code-header-type "code-header")
+		       (#.vm:function-header-type "function")
+		       (#.vm:closure-header-type "closure-header")
+		       (#.vm:funcallable-instance-header-type
+			"funcallable-instance-header")
+		       (#.vm:closure-function-header-type
+			"closure-function")
+		       (#.vm:return-pc-header-type "return-pc-header")
+		       (#.vm:value-cell-header-type "value-cell-header")
+		       (#.vm:symbol-header-type "symbol-header")
+		       (#.vm:sap-type "sap")
+		       (#.vm:weak-pointer-type "weak-pointer")
+		       (#.vm:fdefn-type "fdefn"))
+		     orig-addr)))))
+      (format t "Stack reference at #x~8,'0X~%" object)))
-- 
GitLab