From 9b323cfb115b81152c3c176dcb035b80fa91dd18 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 30 Aug 1991 17:41:25 +0000 Subject: [PATCH] Merged Axmark's changes to make TIME find the time&consing overheads of the syscalls. Use SYSTEM:GET-SYSTEM-INFO for os-independent operation. --- code/time.lisp | 158 +++++++++++++++++++------------------------------ 1 file changed, 61 insertions(+), 97 deletions(-) diff --git a/code/time.lisp b/code/time.lisp index aaa23322e..d2b0876d7 100644 --- a/code/time.lisp +++ b/code/time.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.7 1991/08/23 18:23:54 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.8 1991/08/30 17:41:25 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -270,6 +270,8 @@ (and (dst-check-start-of-month-ge day hour weekday april-1) (not (dst-check-end-of-month-ge day hour weekday october-31)))) +;;;; Time: + (defmacro time (form) "Evaluates the Form and prints timing information on *Trace-Output*." `(%time #'(lambda () ,form))) @@ -293,66 +295,48 @@ (compile nil fun))))) (t fun))) +;;; TIME-GET-SYS-INFO -- Internal +;;; +;;; Return all the files that we want time to report. +;;; +(defun time-get-sys-info () + (multiple-value-bind (user sys faults) + (system:get-system-info) + (values user sys faults (get-bytes-consed)))) + +;;; %TIME -- Internal +;;; +;;; The guts of the TIME macro. Compute overheads, run the (compiled) +;;; function, report the times. +;;; (defun %time (fun) (let ((fun (massage-time-function fun)) old-run-utime - new-run-utime - old-run-stime - new-run-stime - old-real-time - new-real-time - old-page-faults - new-page-faults - real-time-overhead - run-utime-overhead - run-stime-overhead - page-faults-overhead - old-bytes-consed - new-bytes-consed - cons-overhead) + new-run-utime + old-run-stime + new-run-stime + old-real-time + new-real-time + old-page-faults + new-page-faults + real-time-overhead + run-utime-overhead + run-stime-overhead + page-faults-overhead + old-bytes-consed + new-bytes-consed + cons-overhead) ;; Calculate the overhead... - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_allocate gr) - (setq old-page-faults pf)) - (setq old-bytes-consed (get-bytes-consed)) + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (time-get-sys-info)) ;; Do it a second time to make sure everything is faulted in. - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq old-page-faults pf)) - (setq old-bytes-consed (get-bytes-consed)) - - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq new-run-utime utime) - (setq new-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq new-page-faults pf)) - (setq new-bytes-consed (get-bytes-consed)) - + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (time-get-sys-info)) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) (setq run-utime-overhead (- new-run-utime old-run-utime)) (setq run-stime-overhead (- new-run-stime old-run-stime)) (setq page-faults-overhead (- new-page-faults old-page-faults)) @@ -362,48 +346,28 @@ (setq real-time-overhead (- new-real-time old-real-time)) (setq cons-overhead (- new-bytes-consed old-bytes-consed)) ;; Now get the initial times. - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq old-page-faults pf)) + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (time-get-sys-info)) (setq old-real-time (get-internal-real-time)) - (setq old-bytes-consed (get-bytes-consed)) (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq new-run-utime (- utime run-utime-overhead)) - (setq new-run-stime (- stime run-stime-overhead))))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq new-page-faults (- pf page-faults-overhead))) + ;; Execute the form and return its values. + (funcall fun) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (setq new-bytes-consed (- (get-bytes-consed) cons-overhead)) (format *trace-output* - "~&Evaluation took:~% ~ - ~S second~:P of real time~% ~ - ~S second~:P of user run time~% ~ - ~S second~:P of system run time~% ~ - ~S page fault~:P and~% ~ - ~S bytes consed.~%" - (max (/ (- new-real-time old-real-time) - (float internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) - (max (- new-page-faults old-page-faults) 0) - (max (- new-bytes-consed old-bytes-consed) 0))))) + "~&Evaluation took:~% ~ + ~S second~:P of real time~% ~ + ~S second~:P of user run time~% ~ + ~S second~:P of system run time~% ~ + ~S page fault~:P and~% ~ + ~S bytes consed.~%" + (max (/ (- new-real-time old-real-time) + (float internal-time-units-per-second)) + 0.0) + (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) + (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) + (max (- new-page-faults old-page-faults) 0) + (max (- new-bytes-consed old-bytes-consed) 0))))) -- GitLab