Artifact 5d20e26e010e7140c03b2a4812cf90c6121817a70b1619b54f56d8464b7a54a1:

• File psl-1983/3-1/util/time-fnc.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5181) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/time-fnc.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5181) [annotate] [blame] [check-ins using]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Time-fnc.sl : code to time function calls.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Written by Douglas Lanam. (November 1982).
;;
;; To be compiled inside `pfrl' using the command:
;;	(compile-file time-fnc).
;;
;; The object created is usuable in any psl on machine it is compiled for.
;;
;;  Usage:
;;
;;	do 
;;	(timef function-name-1 function-name-2 ...)
;;
;;	Timef is a fexpr.
;;	It will redefine the functions named so that timing information is
;;	kept on these functions.  
;;	This information is kept on the property list of the function name.
;;	The properties used are `time' and `number-of-calls'.
;;
;;	(get function-name 'time) gives you the total time in the function.
;;	(not counting gc time).
;;	Note, this is the time from entrance to exit.
;;	The timef function redefines the function with an
;;	unwind-protect, so calls that are interrupted
;;	by *throws are counted.
;;
;;	(get function-name 'number-of-calls) gives you the number of times
;;	the function is called.
;;
;;	To stop timing do : 
;;	(untimef function-name1 ..)
;;	or do (untimef) for all functions.
;;	(untimef) is a fexpr.
;;
;;	To print timing information do 
;;	(print-time-info function-name-1 function-name-2 ..)
;;
;;	or do (print-time-info) for timing information on all function names.
;;
;;	special variables used: 
;;	*timed-functions* : list of all functions currently being timed.
;;	*all-timed-functions* : list of all functions ever timed in the
;;		current session.
;;
;;	Comment: if tr is called on a called on a function that is already
;;	being timed, and then untimef is called on the function, the
;;	function will no longer be traced.
;;
(defvar *timed-functions* nil)
(defvar *all-timed-functions* nil)

(defun timef fexpr (names)
  (cond ((null names) *timed-functions*)
	((f-mapc
	  '(lambda (x)
		   (or (memq x *timed-functions*)
		       (let ((a (getd x)))
			    (cond (a (put x 'orig-function-def a)
				     (setq *timed-functions*
					   (cons x *timed-functions*))
				     (or (memq x *all-timed-functions*)
					 (setq *all-timed-functions*
					       (cons x *all-timed-functions*)))
				     (set-up-time-function
				      (car a) x (cdr a)))
				  (t (princ x) 
				     (princ " is not a defined function.")
				     (terpri))))))
	  names))))

(defun set-up-time-function (type x old-func)
  (let ((y (cond ((codep old-func)
		  (code-number-of-arguments old-func))
		 (t (length (cadr old-func)))))
	(args) (function) (result-var (gensym)) (gc-time-var (gensym))
	(time-var (gensym)))
       (do ((i y (difference i 1)))
	   ((= i 0))
	   (setq args (cons (gensym) args)))
       (putd x type
	     `(lambda ,args
		      (time-function ',x ',old-func 
				     (list (time) . ,args))))
       x))

(defvar |* timing time *| 0)

#+dec20
(defvar *call-overhead-time* 0.147)

#+vax
(defvar *call-overhead-time* 0.1)

#+dec20
(defvar *time-overhead-time* 0.437)

#+vax
(defvar *time-overhead-time* 1.3)

(defvar |* number of sub time calls *| 0)

(defun time-function (name function-pointer arguments)
  (let ((itime-var (car arguments)) (result) (n)
	(endt) (total-fnc-time) (time-var) (gc-time-var))
       (unwind-protect
	(let ((|* timing time *| 0)
	      (|* number of sub time calls *| 0))
	     (unwind-protect
	      (let () (setq gc-time-var gctime* time-var (time)
			    result (apply function-pointer (cdr arguments))
			    endt (time))
		   result)
	      (cond
	       (time-var
		(or endt (setq endt (time)))
		(Setq n |* number of sub time calls *|)
		(put name 'number-of-sub-time-calls
		     (+ n (or (get name 'number-of-sub-time-calls) 0)))
		(setq total-fnc-time (- (- endt time-var) |* timing time *|))
		(put name 'time
		     (+ (or (get name 'time) 0)
			(- total-fnc-time (- gctime* gc-time-var))))
		(put name 'number-of-calls
		     (1+ (or (get name 'number-of-calls) 0)))))))
	(prog ()
	      (setq |* timing time *|
		    (- (- |* timing time *| itime-var) total-fnc-time)))
	      (setq |* number of sub time calls *| 
		    (1+ |* number of sub time calls *|))
	      (setq |* timing time *| (+ |* timing time *| (time)))))))

(defun untimef fexpr (names)
  (f-mapc '(lambda (x)
		   (cond ((memq x *timed-functions*)
			  (let ((a (get x 'orig-function-def)))
			       (cond (a (putd x (car a) (cdr a)))))
			  (setq *timed-functions*
				(delq x *timed-functions*)))))
	  (or names *timed-functions*)))

(defun print-time-info fexpr (names)
  (f-mapc '(lambda (x)
		   (let ((n (get x 'number-of-calls))
			 (ns (get x 'number-of-sub-time-calls))
			 (time) (t1 (get x 'time)))
			(princ x) (princ " ")
			(tab 20)
			(princ (or n 0)) (princ " calls")
			(cond (n 
			       (setq time
				     (max 0 
					  (difference
					   (difference
					    (or t1 0)
					    (times *call-overhead-time*
						   (or n 0)))
					   (times *time-overhead-time*
						  (or ns 0)))))
			       (tab 31) (princ time) (princ " ms")
			       (tab 48) 
			       (princ (quotient (float time) (float n)))
			       (princ " ms\/call")))
			(terpri)))
	  (or names *all-timed-functions*))
  (terpri))