Skip to content
Snippets Groups Projects
Commit 99a37f4d authored by ram's avatar ram
Browse files

Changes for more informative output (mostly from Sean.)

parent 17e94d46
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -73,83 +73,118 @@
(incf sum (* (aref costs i) (aref counts i)))) (incf sum (* (aref costs i) (aref counts i))))
sum)) sum))
;; ;;; FUNCTION-CYCLES -- External.
(defun get-stats (&optional (spaces '(:dynamic)) &key (clear nil)) ;;;
;;; 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 (locally
(declare (optimize (speed 3) (safety 0)) (declare (optimize (speed 3) (safety 0))
(inline vm::map-allocated-objects)) (inline vm::map-allocated-objects))
(without-gcing (without-gcing
(let ((list nil))
(dolist (space spaces) (dolist (space spaces)
(vm::map-allocated-objects (vm::map-allocated-objects
#'(lambda (object type-code size) #'(lambda (object type-code size)
(declare (ignore type-code size)) (declare (ignore type-code size))
(when (kernel:code-component-p object) (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) (when (dyncount-info-p info)
(let ((debug-info (kernel:code-header-ref object 3))) (let* ((debug-info (kernel:code-header-ref object 3))
(format t "Function: ~S Cost: ~S~&XS" (map (di::get-debug-info-function-map debug-info)))
(compiled-debug-info-name debug-info) (declare (vector map))
(dyncount-total-cost info))) (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 (when clear
(clear-dyncount-info info)))))) (clear-dyncount-info info)))
space)))) (dolist (e alist)
#+nil (push e list)))))
(let ((counts (make-hash-table :test #'equal))) space))
(do-hash (k v (backend-template-names *backend*)) list))))
(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))
#| ;;; GET-STATS -- External.
(defun setup-dynamic-count-info (component) ;;;
(let* ((info (ir2-component-dyncount-info (component-info component))) ;;; Returns the cycles of all the functions in the spaces.
(vops (dyncount-info-vops info))) ;;;
(when (producing-fasl-file) (defun get-stats (&key (spaces '(:dynamic)) (clear nil) (top-n 10) (cost 0))
(fasl-validate-structure info *compile-object*)) (let ((list (stable-sort (sort (get-space-list spaces clear)
(do-ir2-blocks (block component) #'> :key #'third) #'string< :key #'second))
(let* ((start-vop (ir2-block-start-vop block)) (package-name "")
(1block (ir2-block-block block)) (i 0)
(block-number (block-number 1block))) (other 0))
(when (and start-vop block-number) (dolist (e list)
(let* ((index (1- block-number)) (unless (string= package-name (second e))
(counts (svref vops index)) (setf package-name (second e))
(length (length counts))) (when (> other cost)
(do ((vop start-vop (vop-next vop))) (format t " ~10:D: Other~&" other))
((null vop)) (setf i 0)
(let ((vop-name (vop-info-name (vop-info vop)))) (setf other 0)
(do ((i 0 (+ i 4))) (when (> (third e) cost)
((or (>= i length) (eq (svref counts i) vop-name)) (format t "Package: ~A~&" package-name)))
(when (>= i length) (cond ((< i top-n)
(incf length 4) (when (> (third e) cost)
(let ((new-counts (format t " ~10:D: ~S~&" (third e) (first e))))
(make-array length :initial-element 0))) (t
(when counts (incf other (third e))))
(replace new-counts counts)) (incf i))
(setf counts new-counts)) (when (> other cost)
(setf (svref counts i) vop-name)) (format t " ~10:D: Other~&" other))))
(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))
|#
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment