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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (hide annotations)
Sat Oct 9 01:08:11 2004 UTC (9 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.25: +3 -3 lines
Enable the cycle counter for ppc.  It seems the time-base counter is
incremente once every 16 clock cycles on a 400 MHz iMac G3.  We assume
that's true for other ppc's.
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 rtoy 1.26 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.26 2004/10/09 01:08:11 rtoy 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 rtoy 1.26 #+(or pentium sparc-v9 ppc)
285 emarsden 1.22 (defun cycle-count/float ()
286     (multiple-value-bind (lo hi)
287     (vm::read-cycle-counter)
288     (+ (* hi (expt 2.0d0 32)) lo)))
289    
290 rtoy 1.26 #-(or pentium sparc-v9 ppc)
291 emarsden 1.22 (defun cycle-count/float () 0.0)
292    
293 gerd 1.24 (defvar *time-consing* nil)
294     (defvar *last-time-consing* nil)
295 gerd 1.25 (defvar *in-get-time-consing* nil)
296 gerd 1.24
297     (defun get-time-consing ()
298 gerd 1.25 (when (and (null *time-consing*) (not *in-get-time-consing*))
299     (let ((*in-get-time-consing* t))
300     (time nil)
301     (setq *time-consing* *last-time-consing*))))
302 gerd 1.24
303 emarsden 1.22
304 ram 1.8 ;;; %TIME -- Internal
305     ;;;
306     ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
307     ;;; function, report the times.
308     ;;;
309 gerd 1.25 (defun %time (fun &optional get-time-p)
310 ram 1.7 (let ((fun (massage-time-function fun))
311     old-run-utime
312 ram 1.8 new-run-utime
313     old-run-stime
314     new-run-stime
315     old-real-time
316     new-real-time
317     old-page-faults
318     new-page-faults
319     real-time-overhead
320     run-utime-overhead
321     run-stime-overhead
322 emarsden 1.22 cycle-count
323 ram 1.8 page-faults-overhead
324     old-bytes-consed
325     new-bytes-consed
326     cons-overhead)
327 gerd 1.24 (get-time-consing)
328 ram 1.2 ;; Calculate the overhead...
329 ram 1.8 (multiple-value-setq
330     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
331     (time-get-sys-info))
332 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
333 ram 1.8 (multiple-value-setq
334     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
335     (time-get-sys-info))
336     (multiple-value-setq
337     (new-run-utime new-run-stime new-page-faults new-bytes-consed)
338     (time-get-sys-info))
339 ram 1.2 (setq run-utime-overhead (- new-run-utime old-run-utime))
340     (setq run-stime-overhead (- new-run-stime old-run-stime))
341     (setq page-faults-overhead (- new-page-faults old-page-faults))
342     (setq old-real-time (get-internal-real-time))
343     (setq old-real-time (get-internal-real-time))
344     (setq new-real-time (get-internal-real-time))
345     (setq real-time-overhead (- new-real-time old-real-time))
346     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
347     ;; Now get the initial times.
348 cracauer 1.20 (setq old-real-time (get-internal-real-time))
349 ram 1.8 (multiple-value-setq
350     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
351     (time-get-sys-info))
352 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
353 emarsden 1.22 (setq cycle-count (- (cycle-count/float)))
354 ram 1.2 (multiple-value-prog1
355 ram 1.8 ;; Execute the form and return its values.
356     (funcall fun)
357 emarsden 1.22 (incf cycle-count (cycle-count/float))
358 ram 1.8 (multiple-value-setq
359 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
360     (time-get-sys-info))
361 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
362 gerd 1.24 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))
363     (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead)))
364 gerd 1.25 (unless *in-get-time-consing*
365     (terpri *trace-output*)
366     (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
367     (format *trace-output*
368     "Evaluation took:~% ~
369     ~S second~:P of real time~% ~
370     ~S second~:P of user run time~% ~
371     ~S second~:P of system run time~% ~
372     ~:D CPU cycles~% ~
373     ~@[[Run times include ~S second~:P GC run time]~% ~]~
374     ~S page fault~:P and~% ~
375     ~:D bytes consed.~%"
376     (max (/ (- new-real-time old-real-time)
377     (float internal-time-units-per-second))
378     0.0)
379     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
380     (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
381     (truncate cycle-count)
382     (unless (zerop gc-run-time)
383     (/ (float gc-run-time)
384     (float internal-time-units-per-second)))
385     (max (- new-page-faults old-page-faults) 0)
386     (max (- bytes-consed (or *time-consing* 0)) 0)))
387     (terpri *trace-output*))
388     (setq *last-time-consing* bytes-consed))))))

  ViewVC Help
Powered by ViewVC 1.1.5