/[cmucl]/src/code/time.lisp
ViewVC logotype

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon Feb 4 13:20:25 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.4: +29 -13 lines
Changed GET-INTERNAL-REAL-TIME to subtract out the time of the first
call to minimize the probability of bignum results.  Changed both
GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME to assume that the
syscall does ERRNO checking and to have a locally unsafe policy.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; This file contains the definitions for the Spice Lisp time functions.
11     ;;; They are mostly fairly straightforwardly implemented as calls to the
12     ;;; time server.
13     ;;;
14     ;;; Written by Rob MacLachlan.
15     ;;;
16     (in-package 'lisp)
17     (export '(internal-time-units-per-second get-internal-real-time
18     get-internal-run-time get-universal-time
19     get-decoded-time encode-universal-time decode-universal-time))
20    
21     (defconstant internal-time-units-per-second 100
22     "The number of internal time units that fit into a second. See
23     Get-Internal-Real-Time and Get-Internal-Run-Time.")
24    
25 wlott 1.4 (defconstant micro-seconds-per-internal-time-unit
26     (/ 1000000 internal-time-units-per-second))
27    
28    
29 ram 1.1 (defmacro not-leap-year (year)
30     (let ((sym (gensym)))
31     `(let ((,sym ,year))
32     (cond ((eq (mod ,sym 4) 0)
33     (and (eq (mod ,sym 100) 0)
34     (not (eq (mod ,sym 400) 0))))
35     (T T)))))
36    
37 ram 1.5
38     ;;; The base number of seconds for our internal "epoch". We initialize this to
39     ;;; the time of the first call to G-I-R-T, and then subtract this out of the
40     ;;; result.
41     ;;;
42     (defvar *internal-real-time-base-seconds* nil)
43     (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
44    
45 ram 1.1 ;;; Get-Internal-Real-Time -- Public
46     ;;;
47     (defun get-internal-real-time ()
48     "Return the real time in the internal time format. This is useful for
49     finding elapsed time. See Internal-Time-Units-Per-Second."
50 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
51     (multiple-value-bind (ignore seconds useconds) (mach:unix-gettimeofday)
52     (declare (ignore ignore))
53     (let ((base *internal-real-time-base-seconds*)
54     (uint (truncate useconds
55     micro-seconds-per-internal-time-unit)))
56     (declare (type (unsigned-byte 32) uint))
57     (cond (base
58     (+ (* (the (unsigned-byte 32) (- seconds base))
59     internal-time-units-per-second)
60     uint))
61     (t
62     (setq *internal-real-time-base-seconds* seconds)
63     uint))))))
64 ram 1.1
65 ram 1.5
66 ram 1.1 ;;; Get-Internal-Run-Time -- Public
67     ;;;
68     (defun get-internal-run-time ()
69     "Return the run time in the internal time format. This is useful for
70     finding CPU usage."
71 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
72     (multiple-value-bind (ignore utime stime)
73     (mach:unix-getrusage mach:rusage_self)
74     (declare (ignore ignore))
75     (values (truncate (the (unsigned-byte 32) (+ utime stime))
76     micro-seconds-per-internal-time-unit)))))
77 wlott 1.4
78 ram 1.1
79     ;;; Subtract from the returned Internal_Time to get the universal time.
80     ;;; The offset between our time base and the Perq one is 2145 weeks and
81     ;;; five days.
82     ;;;
83     (defconstant seconds-in-week (* 60 60 24 7))
84     (defconstant weeks-offset 2145)
85     (defconstant seconds-offset 432000)
86     (defconstant minutes-per-day (* 24 60))
87     (defconstant quarter-days-per-year (1+ (* 365 4)))
88     (defconstant quarter-days-per-century 146097)
89     (defconstant november-17-1858 678882)
90     (defconstant weekday-november-17-1858 2)
91     (defconstant unix-to-universal-time 2208988800)
92    
93     ;;; Make-Universal-Time -- Internal
94     ;;;
95     ;;; Convert a Unix Internal_Time into a universal time.
96     ;;;
97     (defun make-universal-time (weeks msec)
98     (+ (* (- weeks weeks-offset) seconds-in-week)
99     (- (truncate msec 1000) seconds-offset)))
100    
101 ram 1.3
102 ram 1.1 ;;; Get-Universal-Time -- Public
103     ;;;
104     ;;;
105     (defun get-universal-time ()
106     "Returns a single integer for the current time of
107     day in universal time format."
108     (multiple-value-bind (res secs) (mach:unix-gettimeofday)
109     (declare (ignore res))
110     (+ secs unix-to-universal-time)))
111    
112     (defun get-decoded-time ()
113     "Returns nine values specifying the current time as follows:
114 ram 1.3 second, minute, hour, date, month, year, day of week (0 = Monday), T
115     (daylight savings times) or NIL (standard time), and timezone."
116 ram 1.1 (decode-universal-time (get-universal-time)))
117    
118     (defun decode-universal-time (universal-time &optional time-zone)
119 ram 1.3 "Converts a universal-time to decoded time format returning the following
120     nine values: second, minute, hour, date, month, year, day of week (0 =
121     Monday), T (daylight savings time) or NIL (standard time), and timezone.
122     Completely ignores daylight-savings-time when time-zone is supplied."
123 ram 1.1 (declare (type (or fixnum null) time-zone))
124     (multiple-value-bind (weeks secs)
125     (truncate (+ universal-time seconds-offset)
126     seconds-in-week)
127     (let ((weeks (+ weeks weeks-offset))
128     (second NIL)
129     (minute NIL)
130     (hour NIL)
131     (date NIL)
132     (month NIL)
133     (year NIL)
134     (day NIL)
135     (daylight NIL)
136     (timezone (if (null time-zone)
137     (multiple-value-bind (res s us tz)
138     (mach:unix-gettimeofday)
139     (declare (ignore s us))
140     (if res tz 0))
141     (* time-zone 60))))
142     (declare (fixnum timezone))
143     (multiple-value-bind (t1 seconds) (truncate secs 60)
144     (setq second seconds)
145     (setq t1 (- t1 timezone))
146     (let* ((tday (if (< t1 0)
147     (1- (truncate (1+ t1) minutes-per-day))
148     (truncate t1 minutes-per-day))))
149     (multiple-value-setq (hour minute)
150     (truncate (- t1 (* tday minutes-per-day)) 60))
151     (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
152     (tcent (truncate t2 quarter-days-per-century)))
153     (setq t2 (mod t2 quarter-days-per-century))
154     (setq t2 (+ (- t2 (mod t2 4)) 3))
155     (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
156     (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
157     4))))
158     (setq day (mod (+ tday weekday-november-17-1858) 7))
159 ram 1.3 (unless time-zone
160     (if (setq daylight (dst-check days-since-mar0 hour day))
161     (cond ((eq hour 23)
162     (setq hour 0)
163     (setq day (mod (1+ day) 7))
164     (setq days-since-mar0 (1+ days-since-mar0))
165     (if (>= days-since-mar0 366)
166     (if (or (> days-since-mar0 366)
167     (not-leap-year (1+ year)))
168     (setq days-since-mar0 368))))
169     (T (setq hour (1+ hour))))))
170 ram 1.1 (let ((t3 (+ (* days-since-mar0 5) 456)))
171     (cond ((>= t3 1989)
172     (setq t3 (- t3 1836))
173     (setq year (1+ year))))
174     (multiple-value-setq (month t3) (truncate t3 153))
175     (setq date (1+ (truncate t3 5))))))))
176     (values second minute hour date month year day
177     daylight (truncate timezone 60)))))
178    
179     ;;; Encode-Universal-Time -- Public
180     ;;;
181     ;;; Just do a TimeUser:T_UserToInt. If the year is between 0 and 99 we
182     ;;; have to figure out which the "obvious" year is.
183     ;;;
184    
185     (defun encode-universal-time (second minute hour date month year
186     &optional time-zone)
187     "The time values specified in decoded format are converted to
188     universal time, which is returned."
189     (let* ((year (if (< year 100)
190     (multiple-value-bind (sec min hour day month now-year)
191     (get-decoded-time)
192     (declare (ignore sec min hour day month))
193     (do ((y (+ year (* 100 (1- (truncate now-year 100))))
194     (+ y 100)))
195     ((<= (abs (- y now-year)) 50) y)))
196     year))
197     (zone (if time-zone (* time-zone 60)
198     (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)
199     (declare (ignore s us))
200     (if res tz))))
201     (tmonth (- month 3)))
202     (cond ((< tmonth 0)
203     (setq tmonth (+ tmonth 12))
204     (setq year (1- year))))
205     (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
206     (multiple-value-bind (tcent tyear) (truncate year 100)
207     (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
208     (truncate (* tyear quarter-days-per-year) 4)
209     days-since-mar0)
210     november-17-1858))
211     (daylight (dst-check days-since-mar0 (1- hour)
212     (mod (+ tday weekday-november-17-1858) 7)))
213     (tminutes (+ (* hour 60) minute zone)))
214     (if daylight (setq tminutes (- tminutes 60)))
215     (do ((i tminutes (+ i minutes-per-day)))
216     ((>= i 0) (setq tminutes i))
217     (declare (fixnum i))
218     (decf tday 1))
219     (do ((i tminutes (- i minutes-per-day)))
220     ((< i minutes-per-day) (setq tminutes i))
221     (declare (fixnum i))
222     (incf tday 1))
223     (multiple-value-bind (weeks dpart) (truncate tday 7)
224     (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
225     tminutes) 60)
226     second) 1000))))))))
227    
228     ;;; Dst-check -- Internal
229     (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
230     (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
231    
232     (eval-when (compile eval)
233    
234     (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
235     (let ((d (gensym))
236     (h (gensym))
237     (w (gensym))
238     (db (gensym)))
239     `(let ((,d ,day)
240     (,h ,hour)
241     (,w ,weekday)
242     (,db ,daybound))
243     (declare (fixnum ,d ,h ,w ,db))
244     (cond ((< ,d ,db) NIL)
245     ((> (the fixnum (- ,d ,w)) ,db) T)
246     ((and (eq ,w 6) (> ,h 0)) T)
247     (T NIL)))))
248    
249     (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
250     (let ((d (gensym))
251     (h (gensym))
252     (w (gensym))
253     (db (gensym)))
254     `(let ((,d ,day)
255     (,h ,hour)
256     (,w ,weekday)
257     (,db ,daybound))
258     (declare (fixnum ,d ,h ,w ,db))
259     (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
260     ((> (the fixnum (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
261     ((and (eq ,w 6) (> ,h 0)) T)
262     (T NIL)))))
263     )
264    
265     (defun dst-check (day hour weekday)
266     (and (dst-check-start-of-month-ge day hour weekday april-1)
267     (not (dst-check-end-of-month-ge day hour weekday october-31))))
268    
269     (defmacro time (form)
270     "Evaluates the Form and prints timing information on *Trace-Output*."
271 ram 1.2 `(%time #'(lambda () ,form)))
272 ram 1.1
273 ram 1.2 (defun %time (fun)
274     (let (old-run-utime
275     new-run-utime
276     old-run-stime
277     new-run-stime
278     old-real-time
279     new-real-time
280     old-page-faults
281     new-page-faults
282     real-time-overhead
283     run-utime-overhead
284     run-stime-overhead
285     page-faults-overhead
286     old-bytes-consed
287     new-bytes-consed
288     cons-overhead)
289     ;; Calculate the overhead...
290     (multiple-value-bind (err? utime stime)
291     (mach:unix-getrusage mach:rusage_self)
292     (cond ((null err?)
293     (error "Unix system call getrusage failed: ~A."
294     (mach:get-unix-error-msg utime)))
295     (T (setq old-run-utime utime)
296     (setq old-run-stime stime))))
297     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
298     (mach:vm_statistics *task-self*)
299     (declare (ignore ps fc ac ic wc zf ra in ot))
300     (gr-error 'mach:vm_allocate gr)
301     (setq old-page-faults pf))
302     (setq old-bytes-consed (get-bytes-consed))
303     ;; Do it a second time to make sure everything is faulted in.
304     (multiple-value-bind (err? utime stime)
305     (mach:unix-getrusage mach:rusage_self)
306     (cond ((null err?)
307     (error "Unix system call getrusage failed: ~A."
308     (mach:get-unix-error-msg utime)))
309     (T (setq old-run-utime utime)
310     (setq old-run-stime stime))))
311     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
312     (mach:vm_statistics *task-self*)
313     (declare (ignore ps fc ac ic wc zf ra in ot))
314     (gr-error 'mach:vm_statistics gr)
315     (setq old-page-faults pf))
316     (setq old-bytes-consed (get-bytes-consed))
317    
318     (multiple-value-bind (err? utime stime)
319     (mach:unix-getrusage mach:rusage_self)
320     (cond ((null err?)
321     (error "Unix system call getrusage failed: ~A."
322     (mach:get-unix-error-msg utime)))
323     (T (setq new-run-utime utime)
324     (setq new-run-stime stime))))
325     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
326     (mach:vm_statistics *task-self*)
327     (declare (ignore ps fc ac ic wc zf ra in ot))
328     (gr-error 'mach:vm_statistics gr)
329     (setq new-page-faults pf))
330     (setq new-bytes-consed (get-bytes-consed))
331    
332     (setq run-utime-overhead (- new-run-utime old-run-utime))
333     (setq run-stime-overhead (- new-run-stime old-run-stime))
334     (setq page-faults-overhead (- new-page-faults old-page-faults))
335     (setq old-real-time (get-internal-real-time))
336     (setq old-real-time (get-internal-real-time))
337     (setq new-real-time (get-internal-real-time))
338     (setq real-time-overhead (- new-real-time old-real-time))
339     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
340     ;; Now get the initial times.
341     (multiple-value-bind (err? utime stime)
342     (mach:unix-getrusage mach:rusage_self)
343     (cond ((null err?)
344     (error "Unix system call getrusage failed: ~A."
345     (mach:get-unix-error-msg utime)))
346     (T (setq old-run-utime utime)
347     (setq old-run-stime stime))))
348     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
349     (mach:vm_statistics *task-self*)
350     (declare (ignore ps fc ac ic wc zf ra in ot))
351     (gr-error 'mach:vm_statistics gr)
352     (setq old-page-faults pf))
353     (setq old-real-time (get-internal-real-time))
354     (setq old-bytes-consed (get-bytes-consed))
355     (multiple-value-prog1
356     ;; Execute the form and return its values.
357     (funcall fun)
358     (multiple-value-bind (err? utime stime)
359     (mach:unix-getrusage mach:rusage_self)
360     (cond ((null err?)
361     (error "Unix system call getrusage failed: ~A."
362     (mach:get-unix-error-msg utime)))
363     (T (setq new-run-utime (- utime run-utime-overhead))
364     (setq new-run-stime (- stime run-stime-overhead)))))
365     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
366     (mach:vm_statistics *task-self*)
367     (declare (ignore ps fc ac ic wc zf ra in ot))
368     (gr-error 'mach:vm_statistics gr)
369     (setq new-page-faults (- pf page-faults-overhead)))
370     (setq new-real-time (- (get-internal-real-time) real-time-overhead))
371     (setq new-bytes-consed (- (get-bytes-consed) cons-overhead))
372     (format *trace-output*
373     "~&Evaluation took:~% ~
374     ~S second~:P of real time~% ~
375     ~S second~:P of user run time~% ~
376     ~S second~:P of system run time~% ~
377     ~S page fault~:P and~% ~
378     ~S bytes consed.~%"
379     (max (/ (- new-real-time old-real-time)
380     (float internal-time-units-per-second))
381     0.0)
382     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
383     (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
384     (max (- new-page-faults old-page-faults) 0)
385     (max (- new-bytes-consed old-bytes-consed) 0)))))

  ViewVC Help
Powered by ViewVC 1.1.5