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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5