Skip to content
Snippets Groups Projects
dyncount.lisp 5.79 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Runtime support for dynamic statistic collecting.
;;; 
(in-package "C")

(eval-when (compile)
  (when *collect-dynamic-statistics*
    (error "Compiling this file with dynamic stat collection turn on would ~
    be a very bad idea.")))


(eval-when (compile load eval)
  (defparameter *count-adjustments*
    '((return-multiple 152)
      (tail-call-variable 88)
      (unwind 92)
      (throw 116)
      (allocate-vector 72)
      (sxhash-simple-string 248)
      (sxhash-simple-substring 264)
      (copy-to-system-area 1200)
      (copy-from-system-area 1200)
      (system-area-copy 1204)
      (bit-bash-copy 1412)
      (vm::generic-+ 72)
      (vm::generic-- 72)
      (vm::generic-* 184)
      (vm::generic-< 68)
      (vm::generic-> 68)
      (vm::generic-eql 80)
      (vm::generic-= 80)
      (vm::generic-/= 104)
      (%make-weak-pointer 60)
      (make-value-cell 56)
      (vm::make-funcallable-instance 76)
      (make-closure 76)
      (make-complex 60)
      (make-ratio 60)
      (%allocate-bignum 72)
      (make-structure 72)
      (cons 50))))


(defvar *count-adjustments-hashtable*
  (let ((result (make-hash-table :test 'eq)))
    (dolist (entry *count-adjustments*)
      (setf (gethash (car entry) result) (cadr entry)))
    result))


(defvar *vop-counts* nil)


(defun note-dyncount-info (info)
  (declare (type dyncount-info info))
  (let ((counts (dyncount-info-counts info))
	(vops (dyncount-info-vops info)))
    (dotimes (index (length counts))
      (let ((count (aref counts index)))
	(unless (zerop count)
	  (let* ((vop-info (svref vops index))
		 (length (length vop-info)))
	    (do ((i 0 (+ i 4)))
		((>= i length))
	      (let* ((name (svref vop-info i))
		     (adjustment
		      (gethash name *count-adjustments-hashtable* 0))
		     (entry (gethash name *vop-counts*))
		     (counts (* (svref vop-info (1+ i)) count))
		     (cost (* (+ (svref vop-info (+ i 2)) adjustment)
			      count))
		     (elsewhere-cost (* (svref vop-info (+ i 3)) count)))
		(unless entry
		  (setf entry (make-array 4 :initial-element 0))
		  (setf (svref entry 0) name)
		  (setf (gethash name *vop-counts*) entry))
		(incf (svref entry 1) counts)
		(incf (svref entry 2) cost)
		(incf (svref entry 3) elsewhere-cost)))))))))


(defun clear-dyncount-info (info)
  (declare (type dyncount-info info))
  (fill (dyncount-info-counts info) 0)
  nil)


(defun find-info-for (function)
  (declare (type function function))
  (let* ((function (%primitive closure-function function))
	 (component (di::function-code-header function)))
    (do ((end (get-header-data component))
	 (i vm:code-constants-offset (1+ i)))
	((= end i))
      (let ((constant (code-header-ref component i)))
	(when (dyncount-info-p constant)
	  (return constant))))))

#+nil
(defun find-dyncount-info ()
  (declare (inline vm::map-allocated-objects)
	   (optimize (speed 3) (safety 0)))
  (let ((results nil))
    (dolist (space '(:read-only :static :dynamic))
      (vm::map-allocated-objects
       #'(lambda (object type-code size)
	   (declare (ignore type-code size))
	   (when (dyncount-info-p object)
	     (push object results)))
       space))
    (setf *all-dyncount-infos* results)
    (length results)))


(defun generate-report (cut-off sort-by)
  (let ((total-bytes 0)
	(list nil))
    (maphash #'(lambda (key value)
		 (push value list)
		 (unless (eq key 'c:count-me)
		   (incf total-bytes (svref value 2))))
	     *vop-counts*)
    (format t "~30<Vop~>  ~13<Count~> ~17<Cost~> ~5:@<Percent~>~%")
    (let ((total-bytes (coerce total-bytes 'double-float))
	  (entries (sort list #'>
			 :key #'(lambda (x)
				  (svref x
					 (ecase sort-by
					   (:count 1)
					   (:cost 2)))))))
      (dolist (entry entries)
	(when (and cut-off (minusp (decf cut-off)))
	  (return))
	(unless (eq (svref entry 0) 'c:count-me)
	  (format t "~30<~A~>: ~13:D ~17:D ~4,1,2F%~%"
		  (symbol-name (svref entry 0))
		  (svref entry 1)
		  (svref entry 2)
		  (/ (coerce (svref entry 2) 'double-float)
		     total-bytes))))))
  (values))

(defun report-dynamic-vop-counts (&key spaces (cut-off 15) (sort-by :cost))
  (let ((*vop-counts* (make-hash-table :test #'eq)))
    (without-gcing
     (dolist (space (or spaces '(:read-only :static :dynamic)))
       (format t "Scanning ~S space...~%" space)
       (locally
	(declare (optimize (speed 3) (safety 0)))
	(vm::map-allocated-objects
	 #'(lambda (object type-code size)
	     (declare (ignore type-code size))
	     (when (dyncount-info-p object)
	       (note-dyncount-info object)))
	 space))))
    (generate-report cut-off sort-by)))


(defun clear-dynamic-vop-counts (&rest spaces)
  (without-gcing
   (dolist (space (or spaces '(:read-only :static :dynamic)))
     (format t "Scanning ~S space...~%" space)
     (locally
      (declare (optimize (speed 3) (safety 0)))
      (vm::map-allocated-objects
       #'(lambda (object type-code size)
	   (declare (ignore type-code size))
	   (when (dyncount-info-p object)
	     (clear-dyncount-info object)))
       space)))))


(defun check-dynamic-vop-counts (&rest spaces)
  (without-gcing
   (dolist (space (or spaces '(:read-only :static :dynamic)))
     (format t "Scanning ~S space...~%" space)
     (locally
      (declare (optimize (speed 3) (safety 0)))
      (vm::map-allocated-objects
       #'(lambda (object type-code size)
	   (when (dyncount-info-p object)
	     (assert (= (length (dyncount-info-counts object))
			(length (dyncount-info-vops object))))))
       space)))))