Skip to content
Snippets Groups Projects
Commit 0f692183 authored by ram's avatar ram
Browse files

Changed time into the %TIME function, and made TIME just expand into a call of

%TIME with the form wrapped into a lambda.  This helps interpreted uses of
TIME, mainly by reducing the spurious elapsed time for preprocessing the huge
form, but should also produce somewhat more accurate results, since the code in
%TIME always runs compiled.  Theoretically this could have a slight negative
effect on the accuracy of compiled uses by introducing a call, but this should
be well down in the noise, since call overhead should be well less than the
clock resolution.
parent af4d11af
No related branches found
No related tags found
No related merge requests found
...@@ -272,133 +272,118 @@ ...@@ -272,133 +272,118 @@
(defmacro time (form) (defmacro time (form)
"Evaluates the Form and prints timing information on *Trace-Output*." "Evaluates the Form and prints timing information on *Trace-Output*."
(let ((old-run-utime (gensym)) `(%time #'(lambda () ,form)))
(new-run-utime (gensym))
(old-run-stime (gensym))
(new-run-stime (gensym))
(old-real-time (gensym))
(new-real-time (gensym))
(old-page-faults (gensym))
(new-page-faults (gensym))
(real-time-overhead (gensym))
(run-utime-overhead (gensym))
(run-stime-overhead (gensym))
(page-faults-overhead (gensym))
(old-bytes-consed (gensym))
(new-bytes-consed (gensym))
(cons-overhead (gensym))
(err? (gensym))
(utime (gensym))
(stime (gensym)))
`(let (,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)
;; 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))
;; 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) (defun %time (fun)
(mach:unix-getrusage mach:rusage_self) (let (old-run-utime
(cond ((null ,err?) new-run-utime
(error "Unix system call getrusage failed: ~A." old-run-stime
(mach:get-unix-error-msg ,utime))) new-run-stime
(T (setq ,new-run-utime ,utime) old-real-time
(setq ,new-run-stime ,stime)))) new-real-time
(multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) old-page-faults
(mach:vm_statistics *task-self*) new-page-faults
(declare (ignore ps fc ac ic wc zf ra in ot)) real-time-overhead
(gr-error 'mach:vm_statistics gr) run-utime-overhead
(setq ,new-page-faults pf)) run-stime-overhead
(setq ,new-bytes-consed (get-bytes-consed)) page-faults-overhead
old-bytes-consed
(setq ,run-utime-overhead (- ,new-run-utime ,old-run-utime)) new-bytes-consed
(setq ,run-stime-overhead (- ,new-run-stime ,old-run-stime)) cons-overhead)
(setq ,page-faults-overhead (- ,new-page-faults ,old-page-faults)) ;; Calculate the overhead...
(setq ,old-real-time (get-internal-real-time)) (multiple-value-bind (err? utime stime)
(setq ,old-real-time (get-internal-real-time)) (mach:unix-getrusage mach:rusage_self)
(setq ,new-real-time (get-internal-real-time)) (cond ((null err?)
(setq ,real-time-overhead (- ,new-real-time ,old-real-time)) (error "Unix system call getrusage failed: ~A."
(setq ,cons-overhead (- ,new-bytes-consed ,old-bytes-consed)) (mach:get-unix-error-msg utime)))
;; Now get the initial times. (T (setq old-run-utime utime)
(multiple-value-bind (,err? ,utime ,stime) (setq old-run-stime stime))))
(mach:unix-getrusage mach:rusage_self) (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
(cond ((null ,err?) (mach:vm_statistics *task-self*)
(error "Unix system call getrusage failed: ~A." (declare (ignore ps fc ac ic wc zf ra in ot))
(mach:get-unix-error-msg ,utime))) (gr-error 'mach:vm_allocate gr)
(T (setq ,old-run-utime ,utime) (setq old-page-faults pf))
(setq ,old-run-stime ,stime)))) (setq old-bytes-consed (get-bytes-consed))
(multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) ;; Do it a second time to make sure everything is faulted in.
(mach:vm_statistics *task-self*) (multiple-value-bind (err? utime stime)
(declare (ignore ps fc ac ic wc zf ra in ot)) (mach:unix-getrusage mach:rusage_self)
(gr-error 'mach:vm_statistics gr) (cond ((null err?)
(setq ,old-page-faults pf)) (error "Unix system call getrusage failed: ~A."
(setq ,old-real-time (get-internal-real-time)) (mach:get-unix-error-msg utime)))
(setq ,old-bytes-consed (get-bytes-consed)) (T (setq old-run-utime utime)
(multiple-value-prog1 (setq old-run-stime stime))))
;; Execute the form, and return its values. (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
,form (mach:vm_statistics *task-self*)
(multiple-value-bind (,err? ,utime ,stime) (declare (ignore ps fc ac ic wc zf ra in ot))
(mach:unix-getrusage mach:rusage_self) (gr-error 'mach:vm_statistics gr)
(cond ((null ,err?) (setq old-page-faults pf))
(error "Unix system call getrusage failed: ~A." (setq old-bytes-consed (get-bytes-consed))
(mach:get-unix-error-msg ,utime)))
(T (setq ,new-run-utime (- ,utime ,run-utime-overhead)) (multiple-value-bind (err? utime stime)
(setq ,new-run-stime (- ,stime ,run-stime-overhead))))) (mach:unix-getrusage mach:rusage_self)
(multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) (cond ((null err?)
(mach:vm_statistics *task-self*) (error "Unix system call getrusage failed: ~A."
(declare (ignore ps fc ac ic wc zf ra in ot)) (mach:get-unix-error-msg utime)))
(gr-error 'mach:vm_statistics gr) (T (setq new-run-utime utime)
(setq ,new-page-faults (- pf ,page-faults-overhead))) (setq new-run-stime stime))))
(setq ,new-real-time (- (get-internal-real-time) ,real-time-overhead)) (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
(setq ,new-bytes-consed (- (get-bytes-consed) ,cons-overhead)) (mach:vm_statistics *task-self*)
(format *trace-output* (declare (ignore ps fc ac ic wc zf ra in ot))
"~&Evaluation took:~% ~ (gr-error 'mach:vm_statistics gr)
~S second~:P of real time,~% ~ (setq new-page-faults pf))
~S second~:P of user run time,~% ~ (setq new-bytes-consed (get-bytes-consed))
~S second~:P of system run time,~% ~
~S page fault~:P, and~% ~ (setq run-utime-overhead (- new-run-utime old-run-utime))
~S bytes consed.~%" (setq run-stime-overhead (- new-run-stime old-run-stime))
(max (/ (- ,new-real-time ,old-real-time) (setq page-faults-overhead (- new-page-faults old-page-faults))
(float internal-time-units-per-second)) (setq old-real-time (get-internal-real-time))
0.0) (setq old-real-time (get-internal-real-time))
(max (/ (- ,new-run-utime ,old-run-utime) 1000000.0) 0.0) (setq new-real-time (get-internal-real-time))
(max (/ (- ,new-run-stime ,old-run-stime) 1000000.0) 0.0) (setq real-time-overhead (- new-real-time old-real-time))
(max (- ,new-page-faults ,old-page-faults) 0) (setq cons-overhead (- new-bytes-consed old-bytes-consed))
(max (- ,new-bytes-consed ,old-bytes-consed) 0)))))) ;; 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))
(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)))
(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)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment