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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Thu Jul 24 13:59:51 2003 UTC (10 years, 8 months ago) by gerd
Branch: MAIN
Changes since 1.23: +15 -5 lines
	Get rid of the 64 bytes that are shown as being consed when
	calling (TIME NIL).

	* src/code/time.lisp (*time-consing*, *last-time-consing*): New vars.
	(get-time-consing): New function.
	(%time): Call it to get the additional consing overhead of %time.
	Subtract *time-consing* from the result unless null.  Set
	*last-time-consing*.
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 gerd 1.24 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.24 2003/07/24 13:59:51 gerd 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 dtc 1.19 (multiple-value-bind (daylight timezone)
149     (if time-zone
150     (values nil (* time-zone 60 60))
151     (multiple-value-bind
152     (ignore minwest dst)
153     (get-timezone (- universal-time unix-to-universal-time))
154     (declare (ignore ignore))
155     (values dst (* minwest 60))))
156     (declare (fixnum timezone))
157     (multiple-value-bind (weeks secs)
158     (truncate (+ (- universal-time timezone) seconds-offset)
159     seconds-in-week)
160     (let ((weeks (+ weeks weeks-offset)))
161     (multiple-value-bind (t1 second)
162     (truncate secs 60)
163     (let ((tday (truncate t1 minutes-per-day)))
164     (multiple-value-bind (hour minute)
165     (truncate (- t1 (* tday minutes-per-day)) 60)
166     (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
167     (tcent (truncate t2 quarter-days-per-century)))
168     (setq t2 (mod t2 quarter-days-per-century))
169     (setq t2 (+ (- t2 (mod t2 4)) 3))
170     (let* ((year (+ (* tcent 100)
171     (truncate t2 quarter-days-per-year)))
172     (days-since-mar0
173     (1+ (truncate (mod t2 quarter-days-per-year) 4)))
174     (day (mod (+ tday weekday-november-17-1858) 7))
175     (t3 (+ (* days-since-mar0 5) 456)))
176     (cond ((>= t3 1989)
177     (setq t3 (- t3 1836))
178     (setq year (1+ year))))
179     (multiple-value-bind (month t3)
180     (truncate t3 153)
181     (let ((date (1+ (truncate t3 5))))
182     (values second minute hour date month year day
183     daylight
184     (if daylight
185     (1+ (/ timezone 60 60))
186     (/ timezone 60 60))))))))))))))
187 ram 1.1
188 wlott 1.15
189     (defun pick-obvious-year (year)
190     (declare (type (mod 100) year))
191     (let* ((current-year (nth-value 5 (get-decoded-time)))
192     (guess (+ year (* (truncate (- current-year 50) 100) 100))))
193     (declare (type (integer 1900 9999) current-year guess))
194     (if (> (- current-year guess) 50)
195     (+ guess 100)
196     guess)))
197    
198     (defun leap-years-before (year)
199     (let ((years (- year 1901)))
200     (+ (- (truncate years 4)
201     (truncate years 100))
202 ram 1.17 (truncate (+ years 300) 400))))
203 wlott 1.15
204     (defvar *days-before-month*
205     (collect ((results))
206     (results nil)
207     (let ((sum 0))
208     (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
209     (results sum)
210     (incf sum days-per-month)))
211     (coerce (results) 'vector)))
212    
213 ram 1.1 ;;; Encode-Universal-Time -- Public
214     ;;;
215     (defun encode-universal-time (second minute hour date month year
216     &optional time-zone)
217     "The time values specified in decoded format are converted to
218     universal time, which is returned."
219 wlott 1.15 (declare (type (mod 60) second)
220     (type (mod 60) minute)
221     (type (mod 24) hour)
222     (type (integer 1 31) date)
223     (type (integer 1 12) month)
224     (type (or (integer 0 99) (integer 1900)) year)
225     (type (or null rational) time-zone))
226 ram 1.1 (let* ((year (if (< year 100)
227 wlott 1.15 (pick-obvious-year year)
228 ram 1.1 year))
229 wlott 1.15 (days (+ (1- date)
230     (aref *days-before-month* month)
231     (if (> month 2)
232     (leap-years-before (1+ year))
233     (leap-years-before year))
234     (* (- year 1900) 365)))
235     (hours (+ hour (* days 24))))
236     (if time-zone
237     (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
238     (let* ((minwest-guess
239     (nth-value 1
240     (get-timezone (- (* hours 60 60)
241     unix-to-universal-time))))
242     (guess (+ minute (* hours 60) minwest-guess))
243     (minwest
244     (nth-value 1
245     (get-timezone (- (* guess 60)
246     unix-to-universal-time)))))
247     (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
248 ram 1.1
249    
250 ram 1.8 ;;;; Time:
251    
252 ram 1.1 (defmacro time (form)
253     "Evaluates the Form and prints timing information on *Trace-Output*."
254 ram 1.2 `(%time #'(lambda () ,form)))
255 ram 1.1
256 ram 1.7 ;;; MASSAGE-TIME-FUNCTION -- Internal
257     ;;;
258     ;;; Try to compile the closure arg to %TIME if it is interpreted.
259     ;;;
260     (defun massage-time-function (fun)
261     (cond
262     ((eval:interpreted-function-p fun)
263     (multiple-value-bind (def env-p)
264     (function-lambda-expression fun)
265     (declare (ignore def))
266     (cond
267     (env-p
268     (warn "TIME form in a non-null environment, forced to interpret.~@
269     Compiling entire form will produce more accurate times.")
270     fun)
271     (t
272     (compile nil fun)))))
273     (t fun)))
274    
275 ram 1.8 ;;; TIME-GET-SYS-INFO -- Internal
276     ;;;
277 cracauer 1.20 ;;; Return all the values that we want time to report.
278 ram 1.8 ;;;
279     (defun time-get-sys-info ()
280     (multiple-value-bind (user sys faults)
281     (system:get-system-info)
282     (values user sys faults (get-bytes-consed))))
283    
284 emarsden 1.22 #+(or pentium sparc-v9)
285     (defun cycle-count/float ()
286     (multiple-value-bind (lo hi)
287     (vm::read-cycle-counter)
288     (+ (* hi (expt 2.0d0 32)) lo)))
289    
290     #-(or pentium sparc-v9)
291     (defun cycle-count/float () 0.0)
292    
293 gerd 1.24 (defvar *time-consing* nil)
294     (defvar *last-time-consing* nil)
295    
296     (defun get-time-consing ()
297     (when (null *time-consing*)
298     (time nil)
299     (setq *time-consing* *last-time-consing*)))
300    
301 emarsden 1.22
302 ram 1.8 ;;; %TIME -- Internal
303     ;;;
304     ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
305     ;;; function, report the times.
306     ;;;
307 ram 1.2 (defun %time (fun)
308 ram 1.7 (let ((fun (massage-time-function fun))
309     old-run-utime
310 ram 1.8 new-run-utime
311     old-run-stime
312     new-run-stime
313     old-real-time
314     new-real-time
315     old-page-faults
316     new-page-faults
317     real-time-overhead
318     run-utime-overhead
319     run-stime-overhead
320 emarsden 1.22 cycle-count
321 ram 1.8 page-faults-overhead
322     old-bytes-consed
323     new-bytes-consed
324     cons-overhead)
325 gerd 1.24 (get-time-consing)
326 ram 1.2 ;; Calculate the overhead...
327 ram 1.8 (multiple-value-setq
328     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
329     (time-get-sys-info))
330 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
331 ram 1.8 (multiple-value-setq
332     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
333     (time-get-sys-info))
334     (multiple-value-setq
335     (new-run-utime new-run-stime new-page-faults new-bytes-consed)
336     (time-get-sys-info))
337 ram 1.2 (setq run-utime-overhead (- new-run-utime old-run-utime))
338     (setq run-stime-overhead (- new-run-stime old-run-stime))
339     (setq page-faults-overhead (- new-page-faults old-page-faults))
340     (setq old-real-time (get-internal-real-time))
341     (setq old-real-time (get-internal-real-time))
342     (setq new-real-time (get-internal-real-time))
343     (setq real-time-overhead (- new-real-time old-real-time))
344     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
345     ;; Now get the initial times.
346 cracauer 1.20 (setq old-real-time (get-internal-real-time))
347 ram 1.8 (multiple-value-setq
348     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
349     (time-get-sys-info))
350 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
351 emarsden 1.22 (setq cycle-count (- (cycle-count/float)))
352 ram 1.2 (multiple-value-prog1
353 ram 1.8 ;; Execute the form and return its values.
354     (funcall fun)
355 emarsden 1.22 (incf cycle-count (cycle-count/float))
356 ram 1.8 (multiple-value-setq
357 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
358     (time-get-sys-info))
359 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
360 gerd 1.24 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))
361     (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead)))
362 toy 1.21 (terpri *trace-output*)
363     (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
364     (format *trace-output*
365     "Evaluation took:~% ~
366 ram 1.11 ~S second~:P of real time~% ~
367     ~S second~:P of user run time~% ~
368     ~S second~:P of system run time~% ~
369 toy 1.23 ~:D CPU cycles~% ~
370 ram 1.12 ~@[[Run times include ~S second~:P GC run time]~% ~]~
371 ram 1.11 ~S page fault~:P and~% ~
372 cracauer 1.20 ~:D bytes consed.~%"
373 toy 1.21 (max (/ (- new-real-time old-real-time)
374     (float internal-time-units-per-second))
375     0.0)
376     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
377     (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
378 emarsden 1.22 (truncate cycle-count)
379 toy 1.21 (unless (zerop gc-run-time)
380     (/ (float gc-run-time)
381     (float internal-time-units-per-second)))
382     (max (- new-page-faults old-page-faults) 0)
383 gerd 1.24 (max (- bytes-consed (or *time-consing* 0)) 0)))
384     (terpri *trace-output*)
385     (setq *last-time-consing* bytes-consed)))))))

  ViewVC Help
Powered by ViewVC 1.1.5