;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/lh/RCS/profile.lisp,v 395.1 2008/04/20 17:25:45 gene Exp $
;;;
;;; A small profiler for Lisp.  Copied from
;;; "Paradigms of Artificial Intelligence: Case
;;; Studies in Common Lisp", by Peter Norvig.
;;;

(defun profile1 (fn-name)
  "Make the function count how often it is called"
  ;; First save away the old, unprofiled function
  ;; Then make the name be a new function that increments
  ;; a counter and then calls the original function
  (let ((fn (symbol-function fn-name)))
    (unless (eq fn (get fn-name 'profiled-fn))
      (let ((new-fn (profiled-fn fn-name fn)))
	(setf (symbol-function fn-name) new-fn
	      (get fn-name 'profiled-fn) new-fn
	      (get fn-name 'unprofiled-fn) fn
	      (get fn-name 'profile-time) 0
	      (get fn-name 'profile-count) 0))))
  fn-name)

(defun unprofile1 (fn-name)
  "Make the function stop counting how often it is called."
  (setf (get fn-name 'profiled-time) 0)
  (setf (get fn-name 'profile-count) 0)
  (when (eq (symbol-function fn-name) (get fn-name 'profiled-fn))
    ;; normal case: restore unprofiled version
    (setf (symbol-function fn-name)
	  (get fn-name 'unprofiled-fn)))
  fn-name)

(defvar *profiled-functions* nil)

(defmacro profile (&rest fn-names)
  "Profile fn-names.  With no args, list profiled functions."
  `(mapcar #'profile1
	   (setf *profiled-functions*
		 (union *profiled-functions* ',fn-names))))

(defmacro unprofile (&rest fn-names)
  "Stop profiling fn-names.  With no args, stop all profiling."
  `(progn
     (mapcar #'unprofile1
	     ,(if fn-names `',fn-names `*profiled-functions*))
     (setf *profiled-functions*
	   ,(if (null fn-names)
		nil
	      `(set-difference *profiled-functions*
			       ',fn-names)))))

(defun get-fast-time ()
  "Return the elapsed time.  This may wrap around;
use FAST-TIME-DIFFERENCE to compare."
  #+Explorer (time:microsecond-time)    ; do this on an Explorer
  #-Explorer (get-internal-real-time))   ; do this on a non-Explorer

(defun fast-time-difference (end start)
  "Subtract two time points."
  #+Explorer (time:microsecond-time-difference end start)
  #-Explorer (- end start))

(defun fast-time->seconds (time)
  "Convert a fast-time interval into seconds."
  #+Explorer (/ time 1000000.0)
  #-Explorer (/ time internal-time-units-per-second))

(proclaim '(inline profile-enter profile-exit inc-profile-time))

(defun profiled-fn (fn-name fn)
  "Return a function that increments the count, and times."
  #'(lambda (&rest args)
      (profile-enter fn-name)
      (multiple-value-prog1
       (apply fn args)
       (profile-exit fn-name))))

(defvar *profile-call-stack* nil)

(defun profile-enter (fn-name)
  (incf (get fn-name 'profile-count))
  (unless (null *profile-call-stack*)
    ;; Time charged against the calling function:
    (inc-profile-time (first *profile-call-stack*)
		      (car (first *profile-call-stack*))))
  ;; Put a new entry on the stack
  (push (cons fn-name (get-fast-time))
	*profile-call-stack*))

(defun profile-exit (fn-name)
  ;; time charged against the current function:
  (inc-profile-time (pop *profile-call-stack*)
		    fn-name)
  ;; Change the top entry to reflect current time
  (unless (null *profile-call-stack*)
    (setf (cdr (first *profile-call-stack*))
	  (get-fast-time))))

(defun inc-profile-time (entry fn-name)
  (incf (get fn-name 'profile-time)
	(fast-time-difference (get-fast-time) (cdr entry))))

;; I could not find this function definition in the
;; chapter in PAIP.  It's the only function I have
;; written myself & not copied from PAIP.
(defun profile-count (fn-name) (get fn-name 'profile-count))

(defun profile-time (fn-name) (get fn-name 'profile-time))

(defun profile-report (&optional
		       (fn-names (copy-list *profiled-functions*))
		       (key #'profile-count))
  "Report profiling statistics on given functions."
  (let ((total-time (reduce #'+ (mapcar #'profile-time fn-names))))
    (unless (null key)
      (setf fn-names (sort fn-names #'> :key key)))
    (format t "~&Total elapsed time: ~,2F seconds."
	    (fast-time->seconds total-time))
    (format t "~&  Count   Secs Time% Name")
    ;; I added the sort so that the functions which took the
    ;; most time will preceed those that took the least.
    ;; To work exactly like this function from PAIP, you'd
    ;; replace the entire SORT form with "fn-names".
    (loop for name in (sort fn-names #'> :key #'profile-time) do
	  (format t "~&~7D ~6,2F   ~3D% ~A"
		  (profile-count name)
		  (fast-time->seconds (profile-time name))
		  (round (/ (profile-time name) total-time) 0.01)
		  name))))

(defmacro with-profiling (fn-names &rest body)
  `(progn
     (unprofile . ,fn-names)
     (profile . ,fn-names)
     (setf *profile-call-stack* nil)
     (unwind-protect
	 (progn . ,body)
       (profile-report ',fn-names)
       (unprofile . ,fn-names))))

;;; --- end of file ---