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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5