oprofile.lisp 9.94 KB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*-
;;;
;;; This code has been placed in the public domain by the author.
;;; It is distributed without warranty of any kind.
;;;
;;; Description: Simple profiling facility.
;;;
;;; Author: Skef Wholey, Rob MacLachlan
;;;
;;; Current maintainer:	Rob MacLachlan
;;;
;;; Address: Carnegie-Mellon University
;;;          Computer Science Department
;;;	     Pittsburgh, PA 15213
;;;
;;; Net address: ram@cs.cmu.edu
;;;
;;; Copyright status: Public domain.
;;;
;;; Compatibility: Runs in any valid Common Lisp.  Three small implementation-
;;;   dependent changes can be made to improve performance and prettiness.
;;;
;;; Dependencies: The macro Quickly-Get-Time and the function
;;;   Required-Arguments should probably be tailored to the implementation for
;;;   the best results.  They will default to working, albeit inefficent, forms
;;;   in non-CMU implementations.  The Total-Consing macro is used to profile
;;;   consing: in unknown implementations 0 will be used.
;;;   See the "Implementation Parameters" section.
;;;
;;; Note: a timing overhead factor is computed at load time.  This will be
;;;   incorrect if profiling code is run in a different environment than this
;;;   file was loaded in.  For example, saving a core image on a high
;;;   performance machine and running it on a low performance one will result
;;;   in use of an erroneously small timing overhead factor.
;;;
(in-package "OPROFILE")

(export '(*timed-functions* profile unprofile report-time reset-time))



(progn
  #-:cmu
  (eval-when (compile eval)
    (warn
     "You may want to supply an implementation-specific ~
     Quickly-Get-Time function."))

  (defconstant quick-time-units-per-second internal-time-units-per-second)
  
  (defmacro quickly-get-time ()
    `(get-internal-run-time)))


;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
;;; number of required arguments, and use &rest to capture only non-required
;;; arguments.  The function Required-Arguments returns two values: the first
;;; is the number of required arguments, and the second is T iff there are any
;;; non-required arguments (e.g. &optional, &rest, &key).

#+nil
(defun required-arguments (name)
  (let ((function (symbol-function name)))
    (if (eql (system:%primitive get-type function) system:%function-type)
	(let ((min (ldb system:%function-min-args-byte
			(system:%primitive header-ref function
					   system:%function-min-args-slot)))
	      (max (ldb system:%function-max-args-byte
			(system:%primitive header-ref function
					   system:%function-max-args-slot)))
	      (rest (ldb system:%function-rest-arg-byte
			 (system:%primitive header-ref function
					    system:%function-rest-arg-slot)))
	      (key (ldb system:%function-keyword-arg-byte
			(system:%primitive header-ref function
					   system:%function-keyword-arg-slot))))
	  (values min (or (/= min max) (/= rest 0) (/= key 0))))
	(values 0 t))))
	   

#-:cmu
(progn
 (eval-when (compile eval)
   (warn
    "You may want to add an implementation-specific Required-Arguments function."))
 (eval-when (load eval)
   (defun required-arguments (name)
     (declare (ignore name))
     (values 0 t))))



;;; The Total-Consing macro is called to find the total number of bytes consed
;;; since the beginning of time.

#+cmu
(defmacro total-consing () '(ext:get-bytes-consed))

#-:cmu
(progn
  (eval-when (compile eval)
    (warn "No consing will be reported unless a Total-Consing function is ~
           defined."))

  (defmacro total-consing () '0))
    

(defvar *timed-functions* ()
  "List of functions that are currently being timed.")


(defmacro profile (&rest names)
  "Wraps profiling code around the named functions.  The Names are not evaluated,
  as in Trace."
  (do ((names names (cdr names))
       (stuff ()))
      ((null names)
       ;; Keep the compiler quiet by sending standard output to bit bucket.
       `(compiler-let (#|(*standard-output* (make-broadcast-stream))|#)
	  ,@stuff
	  (values)))
    (push (profile-1-function (car names)) stuff)))


;;; A function is profiled by replacing its definition with a closure created by
;;; the following function.  The closure records the starting time, calls the
;;; original function, and records finishing time.  Other closures are used to
;;; perform various operations on the encapsulated function.

(defun profile-1-function (name)
  (multiple-value-bind (min-args optionals-p)
		       (required-arguments name)
    (let ((required-args ()))
      (dotimes (i min-args)
	(push (gensym) required-args))
      `(funcall
	(compile
	 nil
	 ;; Use ' instead of #' below so guaranteed null lexical environment.
	 '(lambda ()
	    (let* ((time 0)
		   (count 0)
		   (consed 0)
		   (old-definition (symbol-function ',name))
		   (new-definition
		    #'(lambda (,@required-args
			       ,@(if optionals-p
				     `(&rest optional-args)))
			(incf count)
			(let ((old-time time)
			      (start-time (quickly-get-time))
			      (old-consed consed)
			      (start-consed (total-consing)))
			  (multiple-value-prog1
			    ,(if optionals-p
				 `(apply old-definition
					 ,@required-args optional-args)
				 `(funcall old-definition ,@required-args))
			    (setq time
				  (+ old-time (- (quickly-get-time)
						 start-time)))
			    (setq consed
				  (+ old-consed (- (total-consing)
						   start-consed))))))))
	      (pushnew ',name *timed-functions*)
	      (setf (get ',name 'read-time)
		    #'(lambda ()
			(values count time consed))
		    (get ',name 'reset-time)
		    #'(lambda ()
			(setq count 0)
			(setq time 0)
			(setq consed 0)
			t)
		    (symbol-function ',name)
		    new-definition
		    (get ',name 'reset-definition)
		    #'(lambda ()
			(remprop ',name 'read-time)
			(remprop ',name 'reset-time)
			(if (eq (symbol-function ',name) new-definition)
			    (setf (symbol-function ',name) old-definition)
			    (warn "The function ~S was redefined without ~
				  unprofiling and reprofiling.~%~
				  Timing figures have not been updated ~
				  since that redefinition."
				  ',name))
			(remprop ',name 'reset-definition)
			(setq *timed-functions*
			      (delete ',name *timed-functions*))
			nil)))))))))


(defmacro unprofile (&rest names)
  "Unwraps the profiling code around the named functions.  Names defaults to the
  list of all currently profiled functions."
  `(dolist (name ,(if names `',names '*timed-functions*) (values))
     (unprofile-1-function name)))

(defun unprofile-1-function (name)
  (if (get name 'reset-definition)
      (funcall (get name 'reset-definition))
      (error "~S is not a function being profiled." name)))


(defmacro report-time (&rest names)
  "Reports the time spent in the named functions.  Names defaults to the list of
  all currently profiled functions."
  `(%report-times ,(if names `',names '*timed-functions*)))


;;; We average the timing overhead over this many iterations.
;;;
(defconstant timer-overhead-iterations 5000)

;;; Compute-Time-Overhead  --  Internal
;;;
;;;    Return as a float the total number of seconds it takes to call both
;;; Quickly-Get-Time and Total-Consing together, plus a funcall thrown in
;;; to represent some of the other overhead.   We also return a something
;;; computed from the results in order to frustrate clever compilers.
;;;
(defun compute-time-overhead-aux (x)
  x)
(proclaim '(notinline compute-time-overhead-aux))
;;;
(defun compute-time-overhead ()
  (let ((foo 0)
	(fun (symbol-function 'compute-time-overhead-aux))
	(start (quickly-get-time)))
    (funcall fun nil)
    (dotimes (i timer-overhead-iterations)
      (setq foo (logxor (funcall fun (quickly-get-time))
			(total-consing)
			foo)))
    (let ((now (quickly-get-time)))
      (values
       (/ (float (- now start))
	  (float timer-overhead-iterations)
	  (float quick-time-units-per-second))
       foo))))


(defvar *time-overhead* (compute-time-overhead))

(defstruct (time-info
	    (:constructor make-time-info (name calls time consing)))
  name
  calls
  time
  consing)


(defun %report-times (names)
  (let ((info ())
	(no-call ()))
    (dolist (name names)
      (multiple-value-bind
	  (calls time consing)
	  (funcall (or (get name 'read-time)
		       (error "~S is not profiled.")))
	(if (zerop calls)
	    (push name no-call)
	    (let ((compensated
		   (- (/ (float time) (float quick-time-units-per-second))
		      (* *time-overhead* (float calls)))))
	      (push (make-time-info name calls
				    (if (minusp compensated) 0.0 compensated)
				    consing)
		    info)))))
    
    (setq info (sort info #'>= :key #'time-info-time))

    (format *trace-output*
	    "~&  Seconds  |  Consed   |  Calls  |  Sec/Call  |  Name:~@
	       ------------------------------------------------------~%")

    (let ((total-time 0.0)
	  (total-consed 0)
	  (total-calls 0))
      (dolist (time info)
	(incf total-time (time-info-time time))
	(incf total-calls (time-info-calls time))
	(incf total-consed (time-info-consing time))
	(format *trace-output*
		"~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%"
		(time-info-time time)
		(time-info-consing time)
		(time-info-calls time)
		(/ (time-info-time time) (float (time-info-calls time)))
		(time-info-name time)))
      (format *trace-output*
	      "------------------------------------------------------~@
	      ~10,3F | ~9:D | ~7:D |            | Total~%"
	      total-time total-consed total-calls)

      (format *trace-output*
	      "~%Estimated total profiling overhead: ~4,2F seconds~%"
	      (* *time-overhead* (float total-calls) 2.0)))

    (when no-call
      (format *trace-output*
	      "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
	      (sort no-call #'string< :key #'symbol-name)))
    (values)))


(defmacro reset-time (&rest names)
  "Resets the time counter for the named functions.  Names defaults to the list
  of all currently profiled functions."
  `(dolist (name ,(if names `',names '*timed-functions*) (values))
     (reset-1-time name)))

(defun reset-1-time (name)
  (if (get name 'reset-time)
      (funcall (get name 'reset-time))
      (error "~S is not a function being profiled.")))