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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Wed Aug 5 20:08:28 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.12: +12 -6 lines
Changed GET-INTERNAL-RUN-TIME to use UNIX-FAST-GETRUSAGE to avoid
number-consing and generic arithmetic.  Also, rearranged the computation so
that the time is correctly computed for up to 457 days, instead of only 71
minutes.
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.13 1992/08/05 20:08:28 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) (unix:unix-gettimeofday)
56 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
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 (truly-the (unsigned-byte 32)
63 (+ (the (unsigned-byte 32)
64 (* (the (unsigned-byte 32) (- seconds base))
65 internal-time-units-per-second))
66 uint)))
67 (t
68 (setq *internal-real-time-base-seconds* seconds)
69 uint))))))
70
71
72 ;;; Get-Internal-Run-Time -- Public
73 ;;;
74 (defun get-internal-run-time ()
75 "Return the run time in the internal time format. This is useful for
76 finding CPU usage."
77 (declare (values (unsigned-byte 32)))
78 (locally (declare (optimize (speed 3) (safety 0)))
79 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
80 (unix:unix-fast-getrusage unix:rusage_self)
81 (declare (ignore ignore)
82 (type (unsigned-byte 31) utime-sec stime-sec)
83 (type (mod 1000000) utime-usec stime-usec))
84 (+ (the (unsigned-byte 32)
85 (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
86 internal-time-units-per-second))
87 (truncate (+ utime-usec stime-usec)
88 micro-seconds-per-internal-time-unit)))))
89
90
91 ;;; Subtract from the returned Internal_Time to get the universal time.
92 ;;; The offset between our time base and the Perq one is 2145 weeks and
93 ;;; five days.
94 ;;;
95 (defconstant seconds-in-week (* 60 60 24 7))
96 (defconstant weeks-offset 2145)
97 (defconstant seconds-offset 432000)
98 (defconstant minutes-per-day (* 24 60))
99 (defconstant quarter-days-per-year (1+ (* 365 4)))
100 (defconstant quarter-days-per-century 146097)
101 (defconstant november-17-1858 678882)
102 (defconstant weekday-november-17-1858 2)
103 (defconstant unix-to-universal-time 2208988800)
104
105 ;;; Make-Universal-Time -- Internal
106 ;;;
107 ;;; Convert a Unix Internal_Time into a universal time.
108 ;;;
109 (defun make-universal-time (weeks msec)
110 (+ (* (- weeks weeks-offset) seconds-in-week)
111 (- (truncate msec 1000) seconds-offset)))
112
113
114 ;;; Get-Universal-Time -- Public
115 ;;;
116 ;;;
117 (defun get-universal-time ()
118 "Returns a single integer for the current time of
119 day in universal time format."
120 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
121 (declare (ignore res))
122 (+ secs unix-to-universal-time)))
123
124 (defun get-decoded-time ()
125 "Returns nine values specifying the current time as follows:
126 second, minute, hour, date, month, year, day of week (0 = Monday), T
127 (daylight savings times) or NIL (standard time), and timezone."
128 (decode-universal-time (get-universal-time)))
129
130 (defun decode-universal-time (universal-time &optional time-zone)
131 "Converts a universal-time to decoded time format returning the following
132 nine values: second, minute, hour, date, month, year, day of week (0 =
133 Monday), T (daylight savings time) or NIL (standard time), and timezone.
134 Completely ignores daylight-savings-time when time-zone is supplied."
135 (declare (type (or fixnum null) time-zone))
136 (multiple-value-bind (weeks secs)
137 (truncate (+ universal-time seconds-offset)
138 seconds-in-week)
139 (let ((weeks (+ weeks weeks-offset))
140 (second NIL)
141 (minute NIL)
142 (hour NIL)
143 (date NIL)
144 (month NIL)
145 (year NIL)
146 (day NIL)
147 (daylight NIL)
148 (timezone (if (null time-zone)
149 (multiple-value-bind (res s us tz)
150 (unix:unix-gettimeofday)
151 (declare (ignore s us))
152 (if res tz 0))
153 (* time-zone 60))))
154 (declare (fixnum timezone))
155 (multiple-value-bind (t1 seconds) (truncate secs 60)
156 (setq second seconds)
157 (setq t1 (- t1 timezone))
158 (let* ((tday (if (< t1 0)
159 (1- (truncate (1+ t1) minutes-per-day))
160 (truncate t1 minutes-per-day))))
161 (multiple-value-setq (hour minute)
162 (truncate (- t1 (* tday minutes-per-day)) 60))
163 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
164 (tcent (truncate t2 quarter-days-per-century)))
165 (setq t2 (mod t2 quarter-days-per-century))
166 (setq t2 (+ (- t2 (mod t2 4)) 3))
167 (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
168 (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
169 4))))
170 (setq day (mod (+ tday weekday-november-17-1858) 7))
171 (unless time-zone
172 (if (setq daylight (dst-check days-since-mar0 hour day))
173 (cond ((eq hour 23)
174 (setq hour 0)
175 (setq day (mod (1+ day) 7))
176 (setq days-since-mar0 (1+ days-since-mar0))
177 (if (>= days-since-mar0 366)
178 (if (or (> days-since-mar0 366)
179 (not-leap-year (1+ year)))
180 (setq days-since-mar0 368))))
181 (T (setq hour (1+ hour))))))
182 (let ((t3 (+ (* days-since-mar0 5) 456)))
183 (cond ((>= t3 1989)
184 (setq t3 (- t3 1836))
185 (setq year (1+ year))))
186 (multiple-value-setq (month t3) (truncate t3 153))
187 (setq date (1+ (truncate t3 5))))))))
188 (values second minute hour date month year day
189 daylight (truncate timezone 60)))))
190
191 ;;; Encode-Universal-Time -- Public
192 ;;;
193 ;;; Just do a TimeUser:T_UserToInt. If the year is between 0 and 99 we
194 ;;; have to figure out which the "obvious" year is.
195 ;;;
196
197 (defun encode-universal-time (second minute hour date month year
198 &optional time-zone)
199 "The time values specified in decoded format are converted to
200 universal time, which is returned."
201 (let* ((year (if (< year 100)
202 (multiple-value-bind (sec min hour day month now-year)
203 (get-decoded-time)
204 (declare (ignore sec min hour day month))
205 (do ((y (+ year (* 100 (1- (truncate now-year 100))))
206 (+ y 100)))
207 ((<= (abs (- y now-year)) 50) y)))
208 year))
209 (zone (if time-zone (* time-zone 60)
210 (multiple-value-bind (res s us tz) (unix:unix-gettimeofday)
211 (declare (ignore s us))
212 (if res tz))))
213 (tmonth (- month 3)))
214 (cond ((< tmonth 0)
215 (setq tmonth (+ tmonth 12))
216 (setq year (1- year))))
217 (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
218 (multiple-value-bind (tcent tyear) (truncate year 100)
219 (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
220 (truncate (* tyear quarter-days-per-year) 4)
221 days-since-mar0)
222 november-17-1858))
223 (daylight (dst-check days-since-mar0 (1- hour)
224 (mod (+ tday weekday-november-17-1858) 7)))
225 (tminutes (+ (* hour 60) minute zone)))
226 (if daylight (setq tminutes (- tminutes 60)))
227 (do ((i tminutes (+ i minutes-per-day)))
228 ((>= i 0) (setq tminutes i))
229 (declare (fixnum i))
230 (decf tday 1))
231 (do ((i tminutes (- i minutes-per-day)))
232 ((< i minutes-per-day) (setq tminutes i))
233 (declare (fixnum i))
234 (incf tday 1))
235 (multiple-value-bind (weeks dpart) (truncate tday 7)
236 (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
237 tminutes) 60)
238 second) 1000))))))))
239
240 ;;; Dst-check -- Internal
241 (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
242 (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
243
244 (eval-when (compile eval)
245
246 (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
247 (let ((d (gensym))
248 (h (gensym))
249 (w (gensym))
250 (db (gensym)))
251 `(let ((,d ,day)
252 (,h ,hour)
253 (,w ,weekday)
254 (,db ,daybound))
255 (declare (fixnum ,d ,h ,w ,db))
256 (cond ((< ,d ,db) NIL)
257 ((> (the fixnum (- ,d ,w)) ,db) T)
258 ((and (eq ,w 6) (> ,h 0)) T)
259 (T NIL)))))
260
261 (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
262 (let ((d (gensym))
263 (h (gensym))
264 (w (gensym))
265 (db (gensym)))
266 `(let ((,d ,day)
267 (,h ,hour)
268 (,w ,weekday)
269 (,db ,daybound))
270 (declare (fixnum ,d ,h ,w ,db))
271 (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
272 ((> (the fixnum (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
273 ((and (eq ,w 6) (> ,h 0)) T)
274 (T NIL)))))
275 )
276
277 (defun dst-check (day hour weekday)
278 (and (dst-check-start-of-month-ge day hour weekday april-1)
279 (not (dst-check-end-of-month-ge day hour weekday october-31))))
280
281 ;;;; Time:
282
283 (defmacro time (form)
284 "Evaluates the Form and prints timing information on *Trace-Output*."
285 `(%time #'(lambda () ,form)))
286
287 ;;; MASSAGE-TIME-FUNCTION -- Internal
288 ;;;
289 ;;; Try to compile the closure arg to %TIME if it is interpreted.
290 ;;;
291 (defun massage-time-function (fun)
292 (cond
293 ((eval:interpreted-function-p fun)
294 (multiple-value-bind (def env-p)
295 (function-lambda-expression fun)
296 (declare (ignore def))
297 (cond
298 (env-p
299 (warn "TIME form in a non-null environment, forced to interpret.~@
300 Compiling entire form will produce more accurate times.")
301 fun)
302 (t
303 (compile nil fun)))))
304 (t fun)))
305
306 ;;; TIME-GET-SYS-INFO -- Internal
307 ;;;
308 ;;; Return all the files that we want time to report.
309 ;;;
310 (defun time-get-sys-info ()
311 (multiple-value-bind (user sys faults)
312 (system:get-system-info)
313 (values user sys faults (get-bytes-consed))))
314
315 ;;; %TIME -- Internal
316 ;;;
317 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
318 ;;; function, report the times.
319 ;;;
320 (defun %time (fun)
321 (let ((fun (massage-time-function fun))
322 old-run-utime
323 new-run-utime
324 old-run-stime
325 new-run-stime
326 old-real-time
327 new-real-time
328 old-page-faults
329 new-page-faults
330 real-time-overhead
331 run-utime-overhead
332 run-stime-overhead
333 page-faults-overhead
334 old-bytes-consed
335 new-bytes-consed
336 cons-overhead)
337 ;; Calculate the overhead...
338 (multiple-value-setq
339 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
340 (time-get-sys-info))
341 ;; Do it a second time to make sure everything is faulted in.
342 (multiple-value-setq
343 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
344 (time-get-sys-info))
345 (multiple-value-setq
346 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
347 (time-get-sys-info))
348 (setq run-utime-overhead (- new-run-utime old-run-utime))
349 (setq run-stime-overhead (- new-run-stime old-run-stime))
350 (setq page-faults-overhead (- new-page-faults old-page-faults))
351 (setq old-real-time (get-internal-real-time))
352 (setq old-real-time (get-internal-real-time))
353 (setq new-real-time (get-internal-real-time))
354 (setq real-time-overhead (- new-real-time old-real-time))
355 (setq cons-overhead (- new-bytes-consed old-bytes-consed))
356 ;; Now get the initial times.
357 (multiple-value-setq
358 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
359 (time-get-sys-info))
360 (setq old-real-time (get-internal-real-time))
361 (let ((start-gc-run-time *gc-run-time*))
362 (multiple-value-prog1
363 ;; Execute the form and return its values.
364 (funcall fun)
365 (multiple-value-setq
366 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
367 (time-get-sys-info))
368 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
369 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
370 (format *trace-output*
371 "~&Evaluation took:~% ~
372 ~S second~:P of real time~% ~
373 ~S second~:P of user run time~% ~
374 ~S second~:P of system run time~% ~
375 ~@[[Run times include ~S second~:P GC run time]~% ~]~
376 ~S page fault~:P and~% ~
377 ~S bytes consed.~%"
378 (max (/ (- new-real-time old-real-time)
379 (float internal-time-units-per-second))
380 0.0)
381 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
382 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
383 (unless (zerop gc-run-time)
384 (/ (float gc-run-time)
385 (float internal-time-units-per-second)))
386 (max (- new-page-faults old-page-faults) 0)
387 (max (- new-bytes-consed old-bytes-consed) 0)))))))

  ViewVC Help
Powered by ViewVC 1.1.5