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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5