diff --git a/compiler/dyncount.lisp b/compiler/dyncount.lisp index 9375d7770c96b192c7e3d683a2f3917bbf941418..e55465308612637846145dd22b3e80175d969f52 100644 --- a/compiler/dyncount.lisp +++ b/compiler/dyncount.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dyncount.lisp,v 1.7 1993/03/12 15:34:04 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dyncount.lisp,v 1.8 1993/08/04 15:54:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -73,83 +73,118 @@ (incf sum (* (aref costs i) (aref counts i)))) sum)) -;; -(defun get-stats (&optional (spaces '(:dynamic)) &key (clear nil)) +;;; FUNCTION-CYCLES -- External. +;;; +;;; When passed a function FUNCTION-CYCLES returns the number of cycles the +;;; function has executed. :clear t clears the costs. +;;; +(defun function-cycles (function &key (clear nil) (verbose nil)) + (let ((info (find-info-for function))) + (when info + (when verbose + (let* ((object (di::compiled-debug-function-component + (di::function-debug-function function))) + (map (di::get-debug-info-function-map + (kernel:code-header-ref object 3))) + (i 0)) + (map 'list + #'(lambda (e) + (when (compiled-debug-function-p e) + (di:do-debug-function-blocks + (ee (di::make-compiled-debug-function e object)) + (let ((cl (di::compiled-debug-block-code-locations ee))) + (cond ((di:debug-block-elsewhere-p ee) + #+nil (format t "Elsewhere~&")) + (t + (format t "Kind: ~S, Cost: ~S~&" + (compiled-debug-function-kind e) + (* (aref (dyncount-info-costs info) i) + (aref (dyncount-info-counts info) i))) + (incf i) + (debug::print-code-location-source-form + (svref cl 0) 0) + (format t "~&"))))))) + map))) + (format t "~S~&" (dyncount-total-cost info)) + (when clear + (clear-dyncount-info info))))) + +;;; GET-SPACE-LIST -- Internal. +;;; +;;; +(defun get-space-list (spaces clear) (locally - (declare (optimize (speed 3) (safety 0)) - (inline vm::map-allocated-objects)) - (without-gcing + (declare (optimize (speed 3) (safety 0)) + (inline vm::map-allocated-objects)) + (without-gcing + (let ((list nil)) (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (kernel:code-component-p object) - (let ((info (kernel:code-header-ref object 5))) + (let ((info (kernel:code-header-ref object 5)) + (j 0) + (sum 0) + (alist)) + (declare (fixnum j)) (when (dyncount-info-p info) - (let ((debug-info (kernel:code-header-ref object 3))) - (format t "Function: ~S Cost: ~S~&XS" - (compiled-debug-info-name debug-info) - (dyncount-total-cost info))) + (let* ((debug-info (kernel:code-header-ref object 3)) + (map (di::get-debug-info-function-map debug-info))) + (declare (vector map)) + (dotimes (i (length map)) + (declare (fixnum i)) + (let ((e (svref map i))) + (when (compiled-debug-function-p e) + (let ((fn (di::make-compiled-debug-function + e object))) + (di:do-debug-function-blocks (blk fn) + (unless (di:debug-block-elsewhere-p blk) + (incf sum + (* (aref (dyncount-info-costs info) j) + (aref (dyncount-info-counts info) j))) + (incf j))) + (let ((a (find (di:debug-function-name fn) + alist :key #'car))) + (cond (a (incf (third a) sum)) + (t + (push (list (di:debug-function-name fn) + (compiled-debug-info-package + debug-info) + sum) + alist))) + (setf sum 0))))))) (when clear - (clear-dyncount-info info)))))) - space)))) - #+nil - (let ((counts (make-hash-table :test #'equal))) - (do-hash (k v (backend-template-names *backend*)) - (declare (ignore v)) - (let ((stats (get k 'vop-stats))) - (when stats - (setf (gethash (symbol-name k) counts) stats) - (when clear - (remprop k 'vop-stats))))) - counts)) - + (clear-dyncount-info info))) + (dolist (e alist) + (push e list))))) + space)) + list)))) -#| -(defun setup-dynamic-count-info (component) - (let* ((info (ir2-component-dyncount-info (component-info component))) - (vops (dyncount-info-vops info))) - (when (producing-fasl-file) - (fasl-validate-structure info *compile-object*)) - (do-ir2-blocks (block component) - (let* ((start-vop (ir2-block-start-vop block)) - (1block (ir2-block-block block)) - (block-number (block-number 1block))) - (when (and start-vop block-number) - (let* ((index (1- block-number)) - (counts (svref vops index)) - (length (length counts))) - (do ((vop start-vop (vop-next vop))) - ((null vop)) - (let ((vop-name (vop-info-name (vop-info vop)))) - (do ((i 0 (+ i 4))) - ((or (>= i length) (eq (svref counts i) vop-name)) - (when (>= i length) - (incf length 4) - (let ((new-counts - (make-array length :initial-element 0))) - (when counts - (replace new-counts counts)) - (setf counts new-counts)) - (setf (svref counts i) vop-name)) - (incf (svref counts (1+ i))))))) - (setf (svref vops index) counts))))) - #+nil - (assem:count-instructions - #'(lambda (vop bytes elsewherep) - (let ((block-number (block-number (ir2-block-block (vop-block vop))))) - (when block-number - (let* ((name (vop-info-name (vop-info vop))) - (counts (svref vops (1- block-number))) - (length (length counts))) - (do ((i 0 (+ i 4))) - ((>= i length) - (error "VOP ~S didn't exist earlier!~% counts=~S" - name counts)) - (when (eq (svref counts i) name) - (incf (svref counts (+ i (if elsewherep 3 2))) bytes) - (return))))))) - *code-segment* - *elsewhere*)) - (undefined-value)) -|# +;;; GET-STATS -- External. +;;; +;;; Returns the cycles of all the functions in the spaces. +;;; +(defun get-stats (&key (spaces '(:dynamic)) (clear nil) (top-n 10) (cost 0)) + (let ((list (stable-sort (sort (get-space-list spaces clear) + #'> :key #'third) #'string< :key #'second)) + (package-name "") + (i 0) + (other 0)) + (dolist (e list) + (unless (string= package-name (second e)) + (setf package-name (second e)) + (when (> other cost) + (format t " ~10:D: Other~&" other)) + (setf i 0) + (setf other 0) + (when (> (third e) cost) + (format t "Package: ~A~&" package-name))) + (cond ((< i top-n) + (when (> (third e) cost) + (format t " ~10:D: ~S~&" (third e) (first e)))) + (t + (incf other (third e)))) + (incf i)) + (when (> other cost) + (format t " ~10:D: Other~&" other))))