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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Fri Apr 15 01:40:07 2005 UTC (9 years ago) by rtoy
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, double-double-init-sparc-2, double-double-base, snapshot-2007-08, snapshot-2007-05, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, snapshot-2007-01, snapshot-2007-02, release-19d, double-double-init-ppc, release-19c, release-19c-base, double-double-init-%make-sparc, snapshot-2005-07, snapshot-2007-03, snapshot-2007-04, snapshot-2007-07, snapshot-2007-06, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, double-double-irrat-end, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, release-19b-base, double-double-init-x86, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2005-10, snapshot-2005-12, release-19c-pre1, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-09, snapshot-2005-08, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, release-19d-branch, double-double-branch, release-19c-branch
Changes since 1.27: +14 -5 lines
lisp/lisp.c:
o Add function for ppc to compute the number of CPU cycles per
  timebase ticks.  Save this in a global variable.

code/time.lisp:
o Adjust cycle-count/float for ppc to use the cycles-per-tick to
  compute the actual number of CPU cycles, so we can display cycles
  instead of ticks.
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.28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.28 2005/04/15 01:40:07 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.28 #+(or pentium sparc-v9)
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 rtoy 1.28 #+ppc
290     (progn
291     (alien:def-alien-variable cycles-per-tick c-call:int)
292     (defun cycle-count/float ()
293     (multiple-value-bind (lo hi)
294     (vm::read-cycle-counter)
295     ;; The cycle counter on PPC isn't really a cycle counter. It
296     ;; counts ticks, so we need to convert ticks to cycles.
297     ;; CYCLES-PER-TICK is the scale factor, computed in C.
298     (* cycles-per-tick (+ (* hi (expt 2.0d0 32)) lo))))
299     )
300 emarsden 1.22
301 rtoy 1.26 #-(or pentium sparc-v9 ppc)
302 emarsden 1.22 (defun cycle-count/float () 0.0)
303    
304 gerd 1.24 (defvar *time-consing* nil)
305     (defvar *last-time-consing* nil)
306 gerd 1.25 (defvar *in-get-time-consing* nil)
307 gerd 1.24
308     (defun get-time-consing ()
309 gerd 1.25 (when (and (null *time-consing*) (not *in-get-time-consing*))
310     (let ((*in-get-time-consing* t))
311     (time nil)
312     (setq *time-consing* *last-time-consing*))))
313 gerd 1.24
314 emarsden 1.22
315 ram 1.8 ;;; %TIME -- Internal
316     ;;;
317     ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
318     ;;; function, report the times.
319     ;;;
320 gerd 1.25 (defun %time (fun &optional get-time-p)
321 ram 1.7 (let ((fun (massage-time-function fun))
322     old-run-utime
323 ram 1.8 new-run-utime
324     old-run-stime
325     new-run-stime
326     old-real-time
327     new-real-time
328     old-page-faults
329     new-page-faults
330     real-time-overhead
331     run-utime-overhead
332     run-stime-overhead
333 emarsden 1.22 cycle-count
334 ram 1.8 page-faults-overhead
335     old-bytes-consed
336     new-bytes-consed
337     cons-overhead)
338 gerd 1.24 (get-time-consing)
339 ram 1.2 ;; Calculate the overhead...
340 ram 1.8 (multiple-value-setq
341     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
342     (time-get-sys-info))
343 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
344 ram 1.8 (multiple-value-setq
345     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
346     (time-get-sys-info))
347     (multiple-value-setq
348     (new-run-utime new-run-stime new-page-faults new-bytes-consed)
349     (time-get-sys-info))
350 ram 1.2 (setq run-utime-overhead (- new-run-utime old-run-utime))
351     (setq run-stime-overhead (- new-run-stime old-run-stime))
352     (setq page-faults-overhead (- new-page-faults old-page-faults))
353     (setq old-real-time (get-internal-real-time))
354     (setq old-real-time (get-internal-real-time))
355     (setq new-real-time (get-internal-real-time))
356     (setq real-time-overhead (- new-real-time old-real-time))
357     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
358     ;; Now get the initial times.
359 cracauer 1.20 (setq old-real-time (get-internal-real-time))
360 ram 1.8 (multiple-value-setq
361     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
362     (time-get-sys-info))
363 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
364 emarsden 1.22 (setq cycle-count (- (cycle-count/float)))
365 ram 1.2 (multiple-value-prog1
366 ram 1.8 ;; Execute the form and return its values.
367     (funcall fun)
368 emarsden 1.22 (incf cycle-count (cycle-count/float))
369 ram 1.8 (multiple-value-setq
370 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
371     (time-get-sys-info))
372 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
373 gerd 1.24 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))
374     (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead)))
375 gerd 1.25 (unless *in-get-time-consing*
376     (terpri *trace-output*)
377     (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
378     (format *trace-output*
379     "Evaluation took:~% ~
380     ~S second~:P of real time~% ~
381     ~S second~:P of user run time~% ~
382     ~S second~:P of system run time~% ~
383 rtoy 1.27 ~:D ~A cycles~% ~
384 gerd 1.25 ~@[[Run times include ~S second~:P GC run time]~% ~]~
385     ~S page fault~:P and~% ~
386     ~:D bytes consed.~%"
387     (max (/ (- new-real-time old-real-time)
388     (float internal-time-units-per-second))
389     0.0)
390     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
391     (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
392     (truncate cycle-count)
393 rtoy 1.28 "CPU"
394 gerd 1.25 (unless (zerop gc-run-time)
395     (/ (float gc-run-time)
396     (float internal-time-units-per-second)))
397     (max (- new-page-faults old-page-faults) 0)
398     (max (- bytes-consed (or *time-consing* 0)) 0)))
399     (terpri *trace-output*))
400     (setq *last-time-consing* bytes-consed))))))

  ViewVC Help
Powered by ViewVC 1.1.5