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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue Feb 6 17:27:40 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Initial revision
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 (defmacro not-leap-year (year)
26 (let ((sym (gensym)))
27 `(let ((,sym ,year))
28 (cond ((eq (mod ,sym 4) 0)
29 (and (eq (mod ,sym 100) 0)
30 (not (eq (mod ,sym 400) 0))))
31 (T T)))))
32
33 ;;; Get-Internal-Real-Time -- Public
34 ;;;
35 ;;;
36 (defun get-internal-real-time ()
37 "Return the real time in the internal time format. This is useful for
38 finding elapsed time. See Internal-Time-Units-Per-Second."
39 (let ((val (system:%primitive get-real-time)))
40 (when (eq val -1)
41 (error "Failed to get real time."))
42 val))
43
44 #|
45 (defun get-internal-real-time ()
46 "Return the real time in the internal time format. This is useful for
47 finding elapsed time. See Internal-Time-Units-Per-Second."
48 (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)
49 (if result (+ (* seconds internal-time-units-per-second) useconds)
50 (error "Unix system call gettimeofday failed: ~A"
51 (mach:get-unix-error-msg seconds)))))
52 |#
53
54 ;;; Get-Internal-Run-Time -- Public
55 ;;;
56 ;;; PmGetTimes returns run time in microseconds. Convert to jiffies.
57 ;;;
58 (defun get-internal-run-time ()
59 "Return the run time in the internal time format. This is useful for
60 finding CPU usage."
61 (let ((val (system:%primitive get-run-time)))
62 (when (eq val -1)
63 (error "Failed to obtain run time."))
64 val))
65
66 #|
67 (defun get-internal-run-time ()
68 "Return the run time in the internal time format. This is useful for
69 finding CPU usage."
70 (multiple-value-bind (result utime stime)
71 (mach:unix-getrusage mach:rusage_self)
72 (if result (+ utime stime)
73 (error "Unix system call getrusage failed: ~A"
74 (mach:get-unix-error-msg utime)))))
75 |#
76
77 ;;; Subtract from the returned Internal_Time to get the universal time.
78 ;;; The offset between our time base and the Perq one is 2145 weeks and
79 ;;; five days.
80 ;;;
81 (defconstant seconds-in-week (* 60 60 24 7))
82 (defconstant weeks-offset 2145)
83 (defconstant seconds-offset 432000)
84 (defconstant minutes-per-day (* 24 60))
85 (defconstant quarter-days-per-year (1+ (* 365 4)))
86 (defconstant quarter-days-per-century 146097)
87 (defconstant november-17-1858 678882)
88 (defconstant weekday-november-17-1858 2)
89 (defconstant unix-to-universal-time 2208988800)
90
91 ;;; Make-Universal-Time -- Internal
92 ;;;
93 ;;; Convert a Unix Internal_Time into a universal time.
94 ;;;
95 (defun make-universal-time (weeks msec)
96 (+ (* (- weeks weeks-offset) seconds-in-week)
97 (- (truncate msec 1000) seconds-offset)))
98
99 ;;; Get-Universal-Time -- Public
100 ;;;
101 ;;;
102 (defun get-universal-time ()
103 "Returns a single integer for the current time of
104 day in universal time format."
105 (multiple-value-bind (res secs) (mach:unix-gettimeofday)
106 (declare (ignore res))
107 (+ secs unix-to-universal-time)))
108
109 ;;; Get-Decoded-Time -- Public
110 ;;;
111 ;;;
112
113 (defun get-decoded-time ()
114 "Returns nine values specifying the current time as follows:
115 second, minute, hour, date, month, year, day of week (0 = Monday),
116 T (daylight savings times) or NIL (standard time), and timezone."
117 (decode-universal-time (get-universal-time)))
118
119 ;;; Decode-Universal-Time -- Public
120 ;;;
121 ;;;
122
123 (defun decode-universal-time (universal-time &optional time-zone)
124 "Converts a universal-time to decoded time format returning
125 the following nine values: second, minute, hour, date, month,
126 year, day of week (0 = Monday), T (daylight savings time) or
127 NIL (standard time), and timezone."
128 (declare (type (or fixnum null) time-zone))
129 (multiple-value-bind (weeks secs)
130 (truncate (+ universal-time seconds-offset)
131 seconds-in-week)
132 (let ((weeks (+ weeks weeks-offset))
133 (second NIL)
134 (minute NIL)
135 (hour NIL)
136 (date NIL)
137 (month NIL)
138 (year NIL)
139 (day NIL)
140 (daylight NIL)
141 (timezone (if (null time-zone)
142 (multiple-value-bind (res s us tz)
143 (mach:unix-gettimeofday)
144 (declare (ignore s us))
145 (if res tz 0))
146 (* time-zone 60))))
147 (declare (fixnum timezone))
148 (multiple-value-bind (t1 seconds) (truncate secs 60)
149 (setq second seconds)
150 (setq t1 (- t1 timezone))
151 (let* ((tday (if (< t1 0)
152 (1- (truncate (1+ t1) minutes-per-day))
153 (truncate t1 minutes-per-day))))
154 (multiple-value-setq (hour minute)
155 (truncate (- t1 (* tday minutes-per-day)) 60))
156 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
157 (tcent (truncate t2 quarter-days-per-century)))
158 (setq t2 (mod t2 quarter-days-per-century))
159 (setq t2 (+ (- t2 (mod t2 4)) 3))
160 (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
161 (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
162 4))))
163 (setq day (mod (+ tday weekday-november-17-1858) 7))
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 (let ((old-run-utime (gensym))
276 (new-run-utime (gensym))
277 (old-run-stime (gensym))
278 (new-run-stime (gensym))
279 (old-real-time (gensym))
280 (new-real-time (gensym))
281 (old-page-faults (gensym))
282 (new-page-faults (gensym))
283 (real-time-overhead (gensym))
284 (run-utime-overhead (gensym))
285 (run-stime-overhead (gensym))
286 (page-faults-overhead (gensym))
287 (old-bytes-consed (gensym))
288 (new-bytes-consed (gensym))
289 (cons-overhead (gensym))
290 (err? (gensym))
291 (utime (gensym))
292 (stime (gensym)))
293 `(let (,old-run-utime
294 ,new-run-utime
295 ,old-run-stime
296 ,new-run-stime
297 ,old-real-time
298 ,new-real-time
299 ,old-page-faults
300 ,new-page-faults
301 ,real-time-overhead
302 ,run-utime-overhead
303 ,run-stime-overhead
304 ,page-faults-overhead
305 ,old-bytes-consed
306 ,new-bytes-consed
307 ,cons-overhead)
308 ;; Calculate the overhead...
309 (multiple-value-bind (,err? ,utime ,stime)
310 (mach:unix-getrusage mach:rusage_self)
311 (cond ((null ,err?)
312 (error "Unix system call getrusage failed: ~A."
313 (mach:get-unix-error-msg ,utime)))
314 (T (setq ,old-run-utime ,utime)
315 (setq ,old-run-stime ,stime))))
316 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
317 (mach:vm_statistics *task-self*)
318 (declare (ignore ps fc ac ic wc zf ra in ot))
319 (gr-error 'mach:vm_allocate gr)
320 (setq ,old-page-faults pf))
321 (setq ,old-bytes-consed (get-bytes-consed))
322 ;; Do it a second time, to make sure everything is faulted in.
323 (multiple-value-bind (,err? ,utime ,stime)
324 (mach:unix-getrusage mach:rusage_self)
325 (cond ((null ,err?)
326 (error "Unix system call getrusage failed: ~A."
327 (mach:get-unix-error-msg ,utime)))
328 (T (setq ,old-run-utime ,utime)
329 (setq ,old-run-stime ,stime))))
330 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
331 (mach:vm_statistics *task-self*)
332 (declare (ignore ps fc ac ic wc zf ra in ot))
333 (gr-error 'mach:vm_statistics gr)
334 (setq ,old-page-faults pf))
335 (setq ,old-bytes-consed (get-bytes-consed))
336
337 (multiple-value-bind (,err? ,utime ,stime)
338 (mach:unix-getrusage mach:rusage_self)
339 (cond ((null ,err?)
340 (error "Unix system call getrusage failed: ~A."
341 (mach:get-unix-error-msg ,utime)))
342 (T (setq ,new-run-utime ,utime)
343 (setq ,new-run-stime ,stime))))
344 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
345 (mach:vm_statistics *task-self*)
346 (declare (ignore ps fc ac ic wc zf ra in ot))
347 (gr-error 'mach:vm_statistics gr)
348 (setq ,new-page-faults pf))
349 (setq ,new-bytes-consed (get-bytes-consed))
350
351 (setq ,run-utime-overhead (- ,new-run-utime ,old-run-utime))
352 (setq ,run-stime-overhead (- ,new-run-stime ,old-run-stime))
353 (setq ,page-faults-overhead (- ,new-page-faults ,old-page-faults))
354 (setq ,old-real-time (get-internal-real-time))
355 (setq ,old-real-time (get-internal-real-time))
356 (setq ,new-real-time (get-internal-real-time))
357 (setq ,real-time-overhead (- ,new-real-time ,old-real-time))
358 (setq ,cons-overhead (- ,new-bytes-consed ,old-bytes-consed))
359 ;; Now get the initial times.
360 (multiple-value-bind (,err? ,utime ,stime)
361 (mach:unix-getrusage mach:rusage_self)
362 (cond ((null ,err?)
363 (error "Unix system call getrusage failed: ~A."
364 (mach:get-unix-error-msg ,utime)))
365 (T (setq ,old-run-utime ,utime)
366 (setq ,old-run-stime ,stime))))
367 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
368 (mach:vm_statistics *task-self*)
369 (declare (ignore ps fc ac ic wc zf ra in ot))
370 (gr-error 'mach:vm_statistics gr)
371 (setq ,old-page-faults pf))
372 (setq ,old-real-time (get-internal-real-time))
373 (setq ,old-bytes-consed (get-bytes-consed))
374 (multiple-value-prog1
375 ;; Execute the form, and return its values.
376 ,form
377 (multiple-value-bind (,err? ,utime ,stime)
378 (mach:unix-getrusage mach:rusage_self)
379 (cond ((null ,err?)
380 (error "Unix system call getrusage failed: ~A."
381 (mach:get-unix-error-msg ,utime)))
382 (T (setq ,new-run-utime (- ,utime ,run-utime-overhead))
383 (setq ,new-run-stime (- ,stime ,run-stime-overhead)))))
384 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
385 (mach:vm_statistics *task-self*)
386 (declare (ignore ps fc ac ic wc zf ra in ot))
387 (gr-error 'mach:vm_statistics gr)
388 (setq ,new-page-faults (- pf ,page-faults-overhead)))
389 (setq ,new-real-time (- (get-internal-real-time) ,real-time-overhead))
390 (setq ,new-bytes-consed (- (get-bytes-consed) ,cons-overhead))
391 (format *trace-output*
392 "~&Evaluation took:~% ~
393 ~S second~:P of real time,~% ~
394 ~S second~:P of user run time,~% ~
395 ~S second~:P of system run time,~% ~
396 ~S page fault~:P, and~% ~
397 ~S bytes consed.~%"
398 (max (/ (- ,new-real-time ,old-real-time)
399 (float internal-time-units-per-second))
400 0.0)
401 (max (/ (- ,new-run-utime ,old-run-utime) 1000000.0) 0.0)
402 (max (/ (- ,new-run-stime ,old-run-stime) 1000000.0) 0.0)
403 (max (- ,new-page-faults ,old-page-faults) 0)
404 (max (- ,new-bytes-consed ,old-bytes-consed) 0))))))

  ViewVC Help
Powered by ViewVC 1.1.5