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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Fri Jul 12 19:19:10 1996 UTC (17 years, 9 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a
Branch point for: RELENG_18
Changes since 1.16: +2 -2 lines
Merged patch from PW that is supposed to fix decode universal time after 2000.
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 1996/07/12 19:19:10 ram 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 (defun get-internal-run-time ()
66 "Return the run time in the internal time format. This is useful for
67 finding CPU usage."
68 (declare (values (unsigned-byte 32)))
69 (locally (declare (optimize (speed 3) (safety 0)))
70 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
71 (unix:unix-fast-getrusage unix:rusage_self)
72 (declare (ignore ignore)
73 (type (unsigned-byte 31) utime-sec stime-sec)
74 (type (mod 1000000) utime-usec stime-usec))
75 (+ (the (unsigned-byte 32)
76 (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
77 internal-time-units-per-second))
78 (truncate (+ utime-usec stime-usec)
79 micro-seconds-per-internal-time-unit)))))
80
81
82 ;;;; Encode and Decode universal times.
83
84 ;;; CURRENT-TIMEZONE -- internal.
85 ;;;
86 ;;; Returns two values:
87 ;;; - the minuteswest of GMT.
88 ;;; - T if daylight savings is in effect, NIL if not.
89 ;;;
90 (alien:def-alien-routine get-timezone c-call:void
91 (when c-call:long :in)
92 (minutes-west c-call:int :out)
93 (daylight-savings-p alien:boolean :out))
94
95
96 ;;; Subtract from the returned Internal_Time to get the universal time.
97 ;;; The offset between our time base and the Perq one is 2145 weeks and
98 ;;; five days.
99 ;;;
100 (defconstant seconds-in-week (* 60 60 24 7))
101 (defconstant weeks-offset 2145)
102 (defconstant seconds-offset 432000)
103 (defconstant minutes-per-day (* 24 60))
104 (defconstant quarter-days-per-year (1+ (* 365 4)))
105 (defconstant quarter-days-per-century 146097)
106 (defconstant november-17-1858 678882)
107 (defconstant weekday-november-17-1858 2)
108 (defconstant unix-to-universal-time 2208988800)
109
110
111 ;;; Get-Universal-Time -- Public
112 ;;;
113 ;;;
114 (defun get-universal-time ()
115 "Returns a single integer for the current time of
116 day in universal time format."
117 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
118 (declare (ignore res))
119 (+ secs unix-to-universal-time)))
120
121 (defun get-decoded-time ()
122 "Returns nine values specifying the current time as follows:
123 second, minute, hour, date, month, year, day of week (0 = Monday), T
124 (daylight savings times) or NIL (standard time), and timezone."
125 (decode-universal-time (get-universal-time)))
126
127
128 (defun decode-universal-time (universal-time &optional time-zone)
129 "Converts a universal-time to decoded time format returning the following
130 nine values: second, minute, hour, date, month, year, day of week (0 =
131 Monday), T (daylight savings time) or NIL (standard time), and timezone.
132 Completely ignores daylight-savings-time when time-zone is supplied."
133 (multiple-value-bind (weeks secs)
134 (truncate (+ universal-time seconds-offset)
135 seconds-in-week)
136 (let* ((weeks (+ weeks weeks-offset))
137 (second NIL)
138 (minute NIL)
139 (hour NIL)
140 (date NIL)
141 (month NIL)
142 (year NIL)
143 (day NIL)
144 (daylight NIL)
145 (timezone (if (null time-zone)
146 (multiple-value-bind
147 (ignore minwest dst)
148 (get-timezone (- universal-time
149 unix-to-universal-time))
150 (declare (ignore ignore))
151 (setf daylight dst)
152 minwest)
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 (let ((t3 (+ (* days-since-mar0 5) 456)))
172 (cond ((>= t3 1989)
173 (setq t3 (- t3 1836))
174 (setq year (1+ year))))
175 (multiple-value-setq (month t3) (truncate t3 153))
176 (setq date (1+ (truncate t3 5))))))))
177 (values second minute hour date month year day
178 daylight
179 (if daylight
180 (1+ (/ timezone 60))
181 (/ timezone 60))))))
182
183
184 (defun pick-obvious-year (year)
185 (declare (type (mod 100) year))
186 (let* ((current-year (nth-value 5 (get-decoded-time)))
187 (guess (+ year (* (truncate (- current-year 50) 100) 100))))
188 (declare (type (integer 1900 9999) current-year guess))
189 (if (> (- current-year guess) 50)
190 (+ guess 100)
191 guess)))
192
193 (defun leap-years-before (year)
194 (let ((years (- year 1901)))
195 (+ (- (truncate years 4)
196 (truncate years 100))
197 (truncate (+ years 300) 400))))
198
199 (defvar *days-before-month*
200 (collect ((results))
201 (results nil)
202 (let ((sum 0))
203 (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
204 (results sum)
205 (incf sum days-per-month)))
206 (coerce (results) 'vector)))
207
208 ;;; Encode-Universal-Time -- Public
209 ;;;
210 (defun encode-universal-time (second minute hour date month year
211 &optional time-zone)
212 "The time values specified in decoded format are converted to
213 universal time, which is returned."
214 (declare (type (mod 60) second)
215 (type (mod 60) minute)
216 (type (mod 24) hour)
217 (type (integer 1 31) date)
218 (type (integer 1 12) month)
219 (type (or (integer 0 99) (integer 1900)) year)
220 (type (or null rational) time-zone))
221 (let* ((year (if (< year 100)
222 (pick-obvious-year year)
223 year))
224 (days (+ (1- date)
225 (aref *days-before-month* month)
226 (if (> month 2)
227 (leap-years-before (1+ year))
228 (leap-years-before year))
229 (* (- year 1900) 365)))
230 (hours (+ hour (* days 24))))
231 (if time-zone
232 (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
233 (let* ((minwest-guess
234 (nth-value 1
235 (get-timezone (- (* hours 60 60)
236 unix-to-universal-time))))
237 (guess (+ minute (* hours 60) minwest-guess))
238 (minwest
239 (nth-value 1
240 (get-timezone (- (* guess 60)
241 unix-to-universal-time)))))
242 (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
243
244
245 ;;;; Time:
246
247 (defmacro time (form)
248 "Evaluates the Form and prints timing information on *Trace-Output*."
249 `(%time #'(lambda () ,form)))
250
251 ;;; MASSAGE-TIME-FUNCTION -- Internal
252 ;;;
253 ;;; Try to compile the closure arg to %TIME if it is interpreted.
254 ;;;
255 (defun massage-time-function (fun)
256 (cond
257 ((eval:interpreted-function-p fun)
258 (multiple-value-bind (def env-p)
259 (function-lambda-expression fun)
260 (declare (ignore def))
261 (cond
262 (env-p
263 (warn "TIME form in a non-null environment, forced to interpret.~@
264 Compiling entire form will produce more accurate times.")
265 fun)
266 (t
267 (compile nil fun)))))
268 (t fun)))
269
270 ;;; TIME-GET-SYS-INFO -- Internal
271 ;;;
272 ;;; Return all the files that we want time to report.
273 ;;;
274 (defun time-get-sys-info ()
275 (multiple-value-bind (user sys faults)
276 (system:get-system-info)
277 (values user sys faults (get-bytes-consed))))
278
279 ;;; %TIME -- Internal
280 ;;;
281 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
282 ;;; function, report the times.
283 ;;;
284 (defun %time (fun)
285 (let ((fun (massage-time-function fun))
286 old-run-utime
287 new-run-utime
288 old-run-stime
289 new-run-stime
290 old-real-time
291 new-real-time
292 old-page-faults
293 new-page-faults
294 real-time-overhead
295 run-utime-overhead
296 run-stime-overhead
297 page-faults-overhead
298 old-bytes-consed
299 new-bytes-consed
300 cons-overhead)
301 ;; Calculate the overhead...
302 (multiple-value-setq
303 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
304 (time-get-sys-info))
305 ;; Do it a second time to make sure everything is faulted in.
306 (multiple-value-setq
307 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
308 (time-get-sys-info))
309 (multiple-value-setq
310 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
311 (time-get-sys-info))
312 (setq run-utime-overhead (- new-run-utime old-run-utime))
313 (setq run-stime-overhead (- new-run-stime old-run-stime))
314 (setq page-faults-overhead (- new-page-faults old-page-faults))
315 (setq old-real-time (get-internal-real-time))
316 (setq old-real-time (get-internal-real-time))
317 (setq new-real-time (get-internal-real-time))
318 (setq real-time-overhead (- new-real-time old-real-time))
319 (setq cons-overhead (- new-bytes-consed old-bytes-consed))
320 ;; Now get the initial times.
321 (multiple-value-setq
322 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
323 (time-get-sys-info))
324 (setq old-real-time (get-internal-real-time))
325 (let ((start-gc-run-time *gc-run-time*))
326 (multiple-value-prog1
327 ;; Execute the form and return its values.
328 (funcall fun)
329 (multiple-value-setq
330 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
331 (time-get-sys-info))
332 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
333 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
334 (format *trace-output*
335 "~&Evaluation took:~% ~
336 ~S second~:P of real time~% ~
337 ~S second~:P of user run time~% ~
338 ~S second~:P of system run time~% ~
339 ~@[[Run times include ~S second~:P GC run time]~% ~]~
340 ~S page fault~:P and~% ~
341 ~S bytes consed.~%"
342 (max (/ (- new-real-time old-real-time)
343 (float internal-time-units-per-second))
344 0.0)
345 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
346 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
347 (unless (zerop gc-run-time)
348 (/ (float gc-run-time)
349 (float internal-time-units-per-second)))
350 (max (- new-page-faults old-page-faults) 0)
351 (max (- new-bytes-consed old-bytes-consed) 0)))))))

  ViewVC Help
Powered by ViewVC 1.1.5