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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Thu Jan 29 07:22:45 1998 UTC (16 years, 2 months ago) by dtc
Branch: MAIN
Changes since 1.17: +16 -1 lines
Add the unix-times unix system call for the sparc svr4 port, and make
use of this to implement get-internal-run-time and
get-system-info. This allows the run time to be obtained on Solaris 2.4,
and is reportedly faster than getrusage on later versions of Solaris.
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     ;;;
7     (ext:file-comment
8 dtc 1.18 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.18 1998/01/29 07:22:45 dtc Exp $")
9 ram 1.6 ;;;
10 ram 1.1 ;;; **********************************************************************
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 ram 1.14 (in-package "LISP")
19 ram 1.1 (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 wlott 1.4 (defconstant micro-seconds-per-internal-time-unit
28     (/ 1000000 internal-time-units-per-second))
29    
30    
31 ram 1.1
32 ram 1.5
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 ram 1.1 ;;; 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 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
46 wlott 1.9 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
47 wlott 1.10 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
48 ram 1.5 (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 wlott 1.10 (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 ram 1.5 (t
59     (setq *internal-real-time-base-seconds* seconds)
60     uint))))))
61 ram 1.1
62 ram 1.5
63 ram 1.1 ;;; Get-Internal-Run-Time -- Public
64     ;;;
65 dtc 1.18 #-(and sparc svr4)
66 ram 1.1 (defun get-internal-run-time ()
67     "Return the run time in the internal time format. This is useful for
68     finding CPU usage."
69 ram 1.13 (declare (values (unsigned-byte 32)))
70 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
71 ram 1.13 (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 dtc 1.18
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 wlott 1.4
96 ram 1.1
97 wlott 1.15 ;;;; 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 ram 1.1 ;;; 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 wlott 1.9 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
133 ram 1.1 (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 ram 1.3 second, minute, hour, date, month, year, day of week (0 = Monday), T
139     (daylight savings times) or NIL (standard time), and timezone."
140 ram 1.1 (decode-universal-time (get-universal-time)))
141    
142 wlott 1.15
143 ram 1.1 (defun decode-universal-time (universal-time &optional time-zone)
144 ram 1.3 "Converts a universal-time to decoded time format returning the following
145 wlott 1.15 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 ram 1.1 (multiple-value-bind (weeks secs)
149     (truncate (+ universal-time seconds-offset)
150     seconds-in-week)
151 wlott 1.15 (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 ram 1.1 (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 wlott 1.15 daylight
194     (if daylight
195     (1+ (/ timezone 60))
196     (/ timezone 60))))))
197 ram 1.1
198 wlott 1.15
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 ram 1.17 (truncate (+ years 300) 400))))
213 wlott 1.15
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 ram 1.1 ;;; 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 wlott 1.15 (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 ram 1.1 (let* ((year (if (< year 100)
237 wlott 1.15 (pick-obvious-year year)
238 ram 1.1 year))
239 wlott 1.15 (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 ram 1.1
259    
260 ram 1.8 ;;;; Time:
261    
262 ram 1.1 (defmacro time (form)
263     "Evaluates the Form and prints timing information on *Trace-Output*."
264 ram 1.2 `(%time #'(lambda () ,form)))
265 ram 1.1
266 ram 1.7 ;;; 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 ram 1.8 ;;; 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 ram 1.2 (defun %time (fun)
300 ram 1.7 (let ((fun (massage-time-function fun))
301     old-run-utime
302 ram 1.8 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 ram 1.2 ;; Calculate the overhead...
317 ram 1.8 (multiple-value-setq
318     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
319     (time-get-sys-info))
320 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
321 ram 1.8 (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 ram 1.2 (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 ram 1.8 (multiple-value-setq
337     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
338     (time-get-sys-info))
339 ram 1.2 (setq old-real-time (get-internal-real-time))
340 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
341 ram 1.2 (multiple-value-prog1
342 ram 1.8 ;; Execute the form and return its values.
343     (funcall fun)
344     (multiple-value-setq
345 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
346     (time-get-sys-info))
347 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
348 ram 1.11 (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 ram 1.12 ~@[[Run times include ~S second~:P GC run time]~% ~]~
355 ram 1.11 ~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 ram 1.12 (unless (zerop gc-run-time)
363     (/ (float gc-run-time)
364     (float internal-time-units-per-second)))
365 ram 1.11 (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