From 6a412b21a73157e3db15f7ff8e626b28bf36c865 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 17 Aug 1993 16:41:19 +0000 Subject: [PATCH] Initial revision --- code/cprofile.lisp | 415 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 415 insertions(+) create mode 100644 code/cprofile.lisp diff --git a/code/cprofile.lisp b/code/cprofile.lisp new file mode 100644 index 000000000..27b5bc5a6 --- /dev/null +++ b/code/cprofile.lisp @@ -0,0 +1,415 @@ +;;; -*- Package: CPROFILE -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/cprofile.lisp,v 1.1 1993/08/17 16:41:19 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains run-time support for collecting dynamic profiling +;;; information from code instrumented by the compiler. +;;; +(defpackage "CPROFILE" + (:use "C" "DI" "KERNEL" "EXTENSIONS" "LISP" "SYSTEM")) +(in-package "C") +(export '(dyncount-info dyncount-info-p) "C") +(in-package "CPROFILE") + +(eval-when (compile) + (when *collect-dynamic-statistics* + (error "You don't want to compile this file with profiling."))) + + +;;; Represents a single high-cost code object we've pulled out of memory. +;;; +(defstruct (selection-elt + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :type t :identity t))))) + ;; + ;; The code-object we're collecting info for. + (code nil) + ;; + ;; The Dyncount-Info for this object (the first constant.) + (info nil :type (or dyncount-info null)) + ;; + ;; The total cost associated with this code object. + (cost 0d0 :type double-float) + + ;; + ;; Remaining slots only filled in when we have definitely selected this + ;; object... + ;; + ;; A copy of the counts vector (so the results don't get modified.) + (counts nil :type (or (simple-array (unsigned-byte 32) (*)) null)) + ;; + ;; A list of lists ((debug-function cost first-index) for all the functions + ;; in this object, where cost is the total cost for this function and + ;; first-index is the index in costs/counts of the first block in this + ;; function. + (functions nil :type list)) + + +;;; Represents a collection of the N most expensive code objects. +;;; +(defstruct (selection + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :type t :identity t) + (format stream "~A, top ~D, cost ~S" (selection-name s) + (length (selection-elements s)) + (selection-total-cost s)))))) + ;; + ;; Some kind of descriptive name. + (name (required-argument) :type string) + ;; + ;; Total cost of all code objects scanned. + (total-cost 0d0 :type double-float) + ;; + ;; List of elements selected. + (elements (list (make-selection-elt :cost -1d0)) :type list)) + + +(defconstant count-me-cost-fudge 3d0 + "Our guess is to how many cycles in each block are really due to + profiling.") + +;;; SAVE-SELECT-RESULT -- Internal +;;; +;;; First copy all of the counts vectors, then find the debug-functions and +;;; costs. This split avoids considering spurious costs related to parsing +;;; debug-info, etc. +;;; +(defun save-select-result (res) + (dolist (elt res) + (declare (optimize (speed 3) (safety 0))) + (let* ((info (selection-elt-info elt)) + (counts (dyncount-info-counts info)) + (len (length counts)) + (new (make-array len :element-type '(unsigned-byte 32)))) + (dotimes (i len) + (setf (aref new i) (aref counts i))) + (setf (selection-elt-counts elt) new))) + + (dolist (elt res) + (let* ((object (selection-elt-code elt)) + (debug-info (code-header-ref object vm:code-debug-info-slot)) + (map (di::get-debug-info-function-map debug-info)) + (costs (dyncount-info-costs (selection-elt-info elt))) + (counts (selection-elt-counts elt)) + (j 0) + (last-j 0)) + (declare (simple-vector map)) + (dotimes (i (length map)) + (declare (fixnum i)) + (let ((e (svref map i))) + (when (c::compiled-debug-function-p e) + (let ((fn (di::make-compiled-debug-function e object)) + (sum 0d0)) + (declare (double-float sum) (type index j)) + (do-debug-function-blocks (blk fn) + (unless (debug-block-elsewhere-p blk) + (incf sum + (* (- (coerce (the (unsigned-byte 31) + (aref costs j)) + 'double-float) + count-me-cost-fudge) + (coerce (the (unsigned-byte 31) + (aref counts j)) + 'double-float))) + (incf j))) + (push (list fn sum last-j) + (selection-elt-functions elt)) + (setq last-j j))))))) + (undefined-value)) + +;;; CLEAR-PROFILE-INFO -- Public +;;; +(defun clear-profile-info (&optional (spaces '(:dynamic))) + "Clear all profiling counts. Call this before running your test." + (declare (inline vm::map-allocated-objects) + (optimize (speed 3) (safety 0))) + (without-gcing + (dolist (space spaces) + (vm::map-allocated-objects + #'(lambda (object type-code size) + (declare (ignore type-code size)) + (when (code-component-p object) + (let ((info (code-header-ref object vm:code-constants-offset))) + (when (dyncount-info-p info) + (clear-dyncount-info info))))) + space))) + (values)) + + +;;; SELECT-PROFILE-RESULT -- Public +;;; +(defun select-profile-result (&key (name "unknown") (n 30) + (spaces '(:dynamic))) + (declare (string name) (list spaces) (type index n)) + (let ((res (loop repeat n collect (make-selection-elt :cost -1d0))) + (min-cost -1d0) + (selection (make-selection :name name))) + (declare (type double-float min-cost) + (inline vm::map-allocated-objects) + (optimize (speed 3) (safety 0))) + (without-gcing + (dolist (space spaces) + (vm::map-allocated-objects + #'(lambda (object type-code size) + (declare (ignore type-code size)) + (when (code-component-p object) + (let ((info (code-header-ref object vm:code-constants-offset))) + (when (dyncount-info-p info) + (let ((costs (dyncount-info-costs info)) + (counts (dyncount-info-counts info)) + (this-cost 0d0)) + (declare (double-float this-cost)) + (dotimes (i (length counts)) + (incf this-cost + (* (coerce (the (unsigned-byte 31) + (aref counts i)) + 'double-float) + (- (coerce (the (unsigned-byte 31) + (aref costs i)) + 'double-float) + count-me-cost-fudge)))) + (incf (selection-total-cost selection) this-cost) + (when (> this-cost min-cost) + (do ((prev res current) + (current (cdr res) (cdr current))) + ((or (null current) + (> (selection-elt-cost (car current)) + this-cost)) + (setf (cdr prev) + (cons (make-selection-elt + :cost this-cost + :code object + :info info) + current)))) + (let ((old (pop res))) + (setq min-cost (selection-elt-cost old))))))))) + space))) + + (loop + (unless res + (error "No profilable code objects found.")) + (unless (minusp (selection-elt-cost (first res))) (return)) + (pop res)) + + (save-select-result res) + (setf (selection-elements selection) res) + selection)) + +(defun function-report (selection &key (top-n 20)) + (let ((selected-funs ())) + (dolist (elt (selection-elements selection)) + (let ((comp-funs ())) + (dolist (fun (selection-elt-functions elt)) + (let* ((name (debug-function-name (first fun))) + (found (assoc name comp-funs :test #'equal))) + (if found + (incf (cdr found) (second fun)) + (push (cons name (second fun)) comp-funs)))) + (setq selected-funs (append comp-funs selected-funs)))) + + (let ((sorted (sort selected-funs #'> :key #'cdr)) + (total 0d0)) + (declare (double-float total)) + (loop for (name . cost) in sorted + repeat top-n do + (format t "~,2E: ~S~%" cost name) + (incf total cost)) + (format t "~,2E: Total~%" total) + (format t "~,2E: Other~%" (- (selection-total-cost selection) total)))) + + (values)) + + +;;; FIND-INFO-FOR -- Interface +;;; +;;; Return the DYNCOUNT-INFO for FUNCTION. +;;; +(defun find-info-for (function) + (declare (type function function)) + (let* ((function (%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)))))) + +;; +(defun clear-dyncount-info (info) + (declare (type dyncount-info info)) + (declare (optimize (speed 3) (safety 0))) + (let ((counts (dyncount-info-counts info))) + (dotimes (i (length counts)) + (setf (aref counts i) 0)))) + +;; +(defun dyncount-total-cost (info) + (let ((costs (dyncount-info-costs info)) + (counts (dyncount-info-counts info)) + (sum 0)) + (dotimes (i (length costs)) + (incf sum (* (aref costs i) (aref counts i)))) + sum)) + + +;;; SAME-SOURCE-P -- Internal +;;; +;;; Return true if two code locations have the same source form. +;;; +(defun same-source-p (x y) + (and (= (code-location-form-number x) + (code-location-form-number y)) + (= (di:code-location-top-level-form-offset x) + (di:code-location-top-level-form-offset y)))) + + +;;; FUNCTION-CYCLES -- External. +;;; +(defun function-cycles (name selection &key (top-n 15) (combine t)) + (declare (type selection selection)) + "Print detailed information about the costs associated with a particular + function in a SELECTION of dynamic statistics. All functions with names + EQUAL to the specified name are reported. If Combine is true, then + all blocks with the same source location are combined into a single entry in + the report." + ;; + ;; DFs = list of (selection-elt . (debug-fun cost first-num)) + ;; Locs = list of (code-location . (loc-cost max-count)) + (collect ((dfs) + (locs)) + (dolist (sel (selection-elements selection)) + (dolist (fun (selection-elt-functions sel)) + (when (equal (debug-function-name (first fun)) name) + (dfs (cons sel fun))))) + (dolist (df (dfs)) + (let* ((num (third (cdr df))) + (sel (car df)) + (counts (selection-elt-counts sel)) + (costs (dyncount-info-costs (selection-elt-info sel)))) + (declare (type index num)) + (do-debug-function-blocks (db (first (cdr df))) + (do-debug-block-locations (loc db) + (let* ((cnt (coerce (aref counts num) 'double-float)) + (cost (* (- (coerce (aref costs num) 'double-float) + count-me-cost-fudge) + cnt))) + (unless (debug-block-elsewhere-p db) + (assert (member (code-location-kind loc) + '(:block-start :non-local-entry))) + (let ((found (and combine + (assoc loc (locs) :test #'same-source-p)))) + (cond (found + (incf (second found) cost) + (setf (third found) + (max (the double-float (third found)) cnt))) + (t + (locs (list loc cost cnt))))) + (incf num)) + (return)))))) + + (let ((locs (stable-sort (locs) #'>= :key #'second))) + (dolist (loc (subseq locs 0 (min (length locs) top-n))) + (format t "~%~,2E cycles, ~[not run, ~;~:; ~:*~D repeats, ~]~ + ~S:~% " + (second loc) + (truncate (third loc)) + (debug-function-name (code-location-debug-function (car loc)))) + (debug::print-code-location-source-form (car loc) 0) + (fresh-line)))) + (values)) + +#+nil +;;; GET-SPACE-LIST -- Internal. +;;; +;;; +(defun get-space-list (spaces clear) + (locally + (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)) + (j 0) + (sum 0) + (alist)) + (declare (fixnum j)) + (when (dyncount-info-p 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 (c::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) + (c::compiled-debug-info-package + debug-info) + sum) + alist))) + (setf sum 0))))))) + (when clear + (clear-dyncount-info info))) + (dolist (e alist) + (push e list))))) + space)) + list)))) + +#+nil +;;; 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)))) -- GitLab