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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17.2.1 - (show annotations)
Tue Jun 23 11:22:34 1998 UTC (15 years, 10 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18b
Changes since 1.17: +16 -1 lines
This (huge) revision brings the RELENG_18 branch up to the current HEAD.
Note code/unix-glib2.lisp not yet included -- not sure it is ready to go.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.17.2.1 1998/06/23 11:22:34 pw Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the definitions for the Spice Lisp time functions.
13 ;;; They are mostly fairly straightforwardly implemented as calls to the
14 ;;; time server.
15 ;;;
16 ;;; Written by Rob MacLachlan.
17 ;;;
18 (in-package "LISP")
19 (export '(internal-time-units-per-second get-internal-real-time
20 get-internal-run-time get-universal-time
21 get-decoded-time encode-universal-time decode-universal-time))
22
23 (defconstant internal-time-units-per-second 100
24 "The number of internal time units that fit into a second. See
25 Get-Internal-Real-Time and Get-Internal-Run-Time.")
26
27 (defconstant micro-seconds-per-internal-time-unit
28 (/ 1000000 internal-time-units-per-second))
29
30
31
32
33 ;;; The base number of seconds for our internal "epoch". We initialize this to
34 ;;; the time of the first call to G-I-R-T, and then subtract this out of the
35 ;;; result.
36 ;;;
37 (defvar *internal-real-time-base-seconds* nil)
38 (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
39
40 ;;; Get-Internal-Real-Time -- Public
41 ;;;
42 (defun get-internal-real-time ()
43 "Return the real time in the internal time format. This is useful for
44 finding elapsed time. See Internal-Time-Units-Per-Second."
45 (locally (declare (optimize (speed 3) (safety 0)))
46 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
47 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
48 (let ((base *internal-real-time-base-seconds*)
49 (uint (truncate useconds
50 micro-seconds-per-internal-time-unit)))
51 (declare (type (unsigned-byte 32) uint))
52 (cond (base
53 (truly-the (unsigned-byte 32)
54 (+ (the (unsigned-byte 32)
55 (* (the (unsigned-byte 32) (- seconds base))
56 internal-time-units-per-second))
57 uint)))
58 (t
59 (setq *internal-real-time-base-seconds* seconds)
60 uint))))))
61
62
63 ;;; Get-Internal-Run-Time -- Public
64 ;;;
65 #-(and sparc svr4)
66 (defun get-internal-run-time ()
67 "Return the run time in the internal time format. This is useful for
68 finding CPU usage."
69 (declare (values (unsigned-byte 32)))
70 (locally (declare (optimize (speed 3) (safety 0)))
71 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
72 (unix:unix-fast-getrusage unix:rusage_self)
73 (declare (ignore ignore)
74 (type (unsigned-byte 31) utime-sec stime-sec)
75 (type (mod 1000000) utime-usec stime-usec))
76 (+ (the (unsigned-byte 32)
77 (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
78 internal-time-units-per-second))
79 (truncate (+ utime-usec stime-usec)
80 micro-seconds-per-internal-time-unit)))))
81
82 ;;; Get-Internal-Run-Time -- Public
83 ;;;
84 #+(and sparc svr4)
85 (defun get-internal-run-time ()
86 "Return the run time in the internal time format. This is useful for
87 finding CPU usage."
88 (declare (values (unsigned-byte 32)))
89 (locally (declare (optimize (speed 3) (safety 0)))
90 (multiple-value-bind (ignore utime stime cutime cstime)
91 (unix:unix-times)
92 (declare (ignore ignore cutime cstime)
93 (type (unsigned-byte 31) utime stime))
94 (the (unsigned-byte 32) (+ utime stime)))))
95
96
97 ;;;; Encode and Decode universal times.
98
99 ;;; CURRENT-TIMEZONE -- internal.
100 ;;;
101 ;;; Returns two values:
102 ;;; - the minuteswest of GMT.
103 ;;; - T if daylight savings is in effect, NIL if not.
104 ;;;
105 (alien:def-alien-routine get-timezone c-call:void
106 (when c-call:long :in)
107 (minutes-west c-call:int :out)
108 (daylight-savings-p alien:boolean :out))
109
110
111 ;;; Subtract from the returned Internal_Time to get the universal time.
112 ;;; The offset between our time base and the Perq one is 2145 weeks and
113 ;;; five days.
114 ;;;
115 (defconstant seconds-in-week (* 60 60 24 7))
116 (defconstant weeks-offset 2145)
117 (defconstant seconds-offset 432000)
118 (defconstant minutes-per-day (* 24 60))
119 (defconstant quarter-days-per-year (1+ (* 365 4)))
120 (defconstant quarter-days-per-century 146097)
121 (defconstant november-17-1858 678882)
122 (defconstant weekday-november-17-1858 2)
123 (defconstant unix-to-universal-time 2208988800)
124
125
126 ;;; Get-Universal-Time -- Public
127 ;;;
128 ;;;
129 (defun get-universal-time ()
130 "Returns a single integer for the current time of
131 day in universal time format."
132 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
133 (declare (ignore res))
134 (+ secs unix-to-universal-time)))
135
136 (defun get-decoded-time ()
137 "Returns nine values specifying the current time as follows:
138 second, minute, hour, date, month, year, day of week (0 = Monday), T
139 (daylight savings times) or NIL (standard time), and timezone."
140 (decode-universal-time (get-universal-time)))
141
142
143 (defun decode-universal-time (universal-time &optional time-zone)
144 "Converts a universal-time to decoded time format returning the following
145 nine values: second, minute, hour, date, month, year, day of week (0 =
146 Monday), T (daylight savings time) or NIL (standard time), and timezone.
147 Completely ignores daylight-savings-time when time-zone is supplied."
148 (multiple-value-bind (weeks secs)
149 (truncate (+ universal-time seconds-offset)
150 seconds-in-week)
151 (let* ((weeks (+ weeks weeks-offset))
152 (second NIL)
153 (minute NIL)
154 (hour NIL)
155 (date NIL)
156 (month NIL)
157 (year NIL)
158 (day NIL)
159 (daylight NIL)
160 (timezone (if (null time-zone)
161 (multiple-value-bind
162 (ignore minwest dst)
163 (get-timezone (- universal-time
164 unix-to-universal-time))
165 (declare (ignore ignore))
166 (setf daylight dst)
167 minwest)
168 (* time-zone 60))))
169 (declare (fixnum timezone))
170 (multiple-value-bind (t1 seconds) (truncate secs 60)
171 (setq second seconds)
172 (setq t1 (- t1 timezone))
173 (let* ((tday (if (< t1 0)
174 (1- (truncate (1+ t1) minutes-per-day))
175 (truncate t1 minutes-per-day))))
176 (multiple-value-setq (hour minute)
177 (truncate (- t1 (* tday minutes-per-day)) 60))
178 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
179 (tcent (truncate t2 quarter-days-per-century)))
180 (setq t2 (mod t2 quarter-days-per-century))
181 (setq t2 (+ (- t2 (mod t2 4)) 3))
182 (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
183 (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
184 4))))
185 (setq day (mod (+ tday weekday-november-17-1858) 7))
186 (let ((t3 (+ (* days-since-mar0 5) 456)))
187 (cond ((>= t3 1989)
188 (setq t3 (- t3 1836))
189 (setq year (1+ year))))
190 (multiple-value-setq (month t3) (truncate t3 153))
191 (setq date (1+ (truncate t3 5))))))))
192 (values second minute hour date month year day
193 daylight
194 (if daylight
195 (1+ (/ timezone 60))
196 (/ timezone 60))))))
197
198
199 (defun pick-obvious-year (year)
200 (declare (type (mod 100) year))
201 (let* ((current-year (nth-value 5 (get-decoded-time)))
202 (guess (+ year (* (truncate (- current-year 50) 100) 100))))
203 (declare (type (integer 1900 9999) current-year guess))
204 (if (> (- current-year guess) 50)
205 (+ guess 100)
206 guess)))
207
208 (defun leap-years-before (year)
209 (let ((years (- year 1901)))
210 (+ (- (truncate years 4)
211 (truncate years 100))
212 (truncate (+ years 300) 400))))
213
214 (defvar *days-before-month*
215 (collect ((results))
216 (results nil)
217 (let ((sum 0))
218 (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
219 (results sum)
220 (incf sum days-per-month)))
221 (coerce (results) 'vector)))
222
223 ;;; Encode-Universal-Time -- Public
224 ;;;
225 (defun encode-universal-time (second minute hour date month year
226 &optional time-zone)
227 "The time values specified in decoded format are converted to
228 universal time, which is returned."
229 (declare (type (mod 60) second)
230 (type (mod 60) minute)
231 (type (mod 24) hour)
232 (type (integer 1 31) date)
233 (type (integer 1 12) month)
234 (type (or (integer 0 99) (integer 1900)) year)
235 (type (or null rational) time-zone))
236 (let* ((year (if (< year 100)
237 (pick-obvious-year year)
238 year))
239 (days (+ (1- date)
240 (aref *days-before-month* month)
241 (if (> month 2)
242 (leap-years-before (1+ year))
243 (leap-years-before year))
244 (* (- year 1900) 365)))
245 (hours (+ hour (* days 24))))
246 (if time-zone
247 (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
248 (let* ((minwest-guess
249 (nth-value 1
250 (get-timezone (- (* hours 60 60)
251 unix-to-universal-time))))
252 (guess (+ minute (* hours 60) minwest-guess))
253 (minwest
254 (nth-value 1
255 (get-timezone (- (* guess 60)
256 unix-to-universal-time)))))
257 (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
258
259
260 ;;;; Time:
261
262 (defmacro time (form)
263 "Evaluates the Form and prints timing information on *Trace-Output*."
264 `(%time #'(lambda () ,form)))
265
266 ;;; MASSAGE-TIME-FUNCTION -- Internal
267 ;;;
268 ;;; Try to compile the closure arg to %TIME if it is interpreted.
269 ;;;
270 (defun massage-time-function (fun)
271 (cond
272 ((eval:interpreted-function-p fun)
273 (multiple-value-bind (def env-p)
274 (function-lambda-expression fun)
275 (declare (ignore def))
276 (cond
277 (env-p
278 (warn "TIME form in a non-null environment, forced to interpret.~@
279 Compiling entire form will produce more accurate times.")
280 fun)
281 (t
282 (compile nil fun)))))
283 (t fun)))
284
285 ;;; TIME-GET-SYS-INFO -- Internal
286 ;;;
287 ;;; Return all the files that we want time to report.
288 ;;;
289 (defun time-get-sys-info ()
290 (multiple-value-bind (user sys faults)
291 (system:get-system-info)
292 (values user sys faults (get-bytes-consed))))
293
294 ;;; %TIME -- Internal
295 ;;;
296 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
297 ;;; function, report the times.
298 ;;;
299 (defun %time (fun)
300 (let ((fun (massage-time-function fun))
301 old-run-utime
302 new-run-utime
303 old-run-stime
304 new-run-stime
305 old-real-time
306 new-real-time
307 old-page-faults
308 new-page-faults
309 real-time-overhead
310 run-utime-overhead
311 run-stime-overhead
312 page-faults-overhead
313 old-bytes-consed
314 new-bytes-consed
315 cons-overhead)
316 ;; Calculate the overhead...
317 (multiple-value-setq
318 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
319 (time-get-sys-info))
320 ;; Do it a second time to make sure everything is faulted in.
321 (multiple-value-setq
322 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
323 (time-get-sys-info))
324 (multiple-value-setq
325 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
326 (time-get-sys-info))
327 (setq run-utime-overhead (- new-run-utime old-run-utime))
328 (setq run-stime-overhead (- new-run-stime old-run-stime))
329 (setq page-faults-overhead (- new-page-faults old-page-faults))
330 (setq old-real-time (get-internal-real-time))
331 (setq old-real-time (get-internal-real-time))
332 (setq new-real-time (get-internal-real-time))
333 (setq real-time-overhead (- new-real-time old-real-time))
334 (setq cons-overhead (- new-bytes-consed old-bytes-consed))
335 ;; Now get the initial times.
336 (multiple-value-setq
337 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
338 (time-get-sys-info))
339 (setq old-real-time (get-internal-real-time))
340 (let ((start-gc-run-time *gc-run-time*))
341 (multiple-value-prog1
342 ;; Execute the form and return its values.
343 (funcall fun)
344 (multiple-value-setq
345 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
346 (time-get-sys-info))
347 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
348 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
349 (format *trace-output*
350 "~&Evaluation took:~% ~
351 ~S second~:P of real time~% ~
352 ~S second~:P of user run time~% ~
353 ~S second~:P of system run time~% ~
354 ~@[[Run times include ~S second~:P GC run time]~% ~]~
355 ~S page fault~:P and~% ~
356 ~S bytes consed.~%"
357 (max (/ (- new-real-time old-real-time)
358 (float internal-time-units-per-second))
359 0.0)
360 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
361 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
362 (unless (zerop gc-run-time)
363 (/ (float gc-run-time)
364 (float internal-time-units-per-second)))
365 (max (- new-page-faults old-page-faults) 0)
366 (max (- new-bytes-consed old-bytes-consed) 0)))))))

  ViewVC Help
Powered by ViewVC 1.1.5