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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Sun Aug 9 03:54:42 2009 UTC (4 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: unicode-string-buffer-impl-base, unicode-string-buffer-base, amd64-dd-start, intl-2-branch-base, release-20a-base, pre-merge-intl-branch, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, intl-branch-base, snapshot-2009-08
Branch point for: unicode-string-buffer-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, intl-2-branch
Changes since 1.29: +2 -2 lines
Fix some typos.  From Paul Foley.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.30 2009/08/09 03:54:42 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
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 (in-package "LISP")
19 (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 (defconstant micro-seconds-per-internal-time-unit
28 (/ 1000000 internal-time-units-per-second))
29
30
31
32
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 ;;; 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 (locally (declare (optimize (speed 3) (safety 0)))
46 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
47 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
48 (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 (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 (t
59 (setq *internal-real-time-base-seconds* seconds)
60 uint))))))
61
62
63 ;;; Get-Internal-Run-Time -- Public
64 ;;;
65 #-(and sparc svr4)
66 (defun get-internal-run-time ()
67 "Return the run time in the internal time format. This is useful for
68 finding CPU usage."
69 (declare (values (unsigned-byte 32)))
70 (locally (declare (optimize (speed 3) (safety 0)))
71 (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
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
96
97 ;;;; Encode and Decode universal times.
98
99 ;;; CURRENT-TIMEZONE -- internal.
100 ;;;
101 ;;; Returns two values:
102 ;;; - the minutes west 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 ;;; 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 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
133 (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 second, minute, hour, date, month, year, day of week (0 = Monday), T
139 (daylight savings times) or NIL (standard time), and timezone."
140 (decode-universal-time (get-universal-time)))
141
142
143 (defun decode-universal-time (universal-time &optional time-zone)
144 "Converts a universal-time to decoded time format returning the following
145 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 (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
188
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 (truncate (+ years 300) 400))))
203
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 ;;; 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 (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 (let* ((year (if (< year 100)
227 (pick-obvious-year year)
228 year))
229 (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
249
250 ;;;; Time:
251
252 (defmacro time (form)
253 "Evaluates the Form and prints timing information on *Trace-Output*."
254 `(%time #'(lambda () ,form)))
255
256 ;;; 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 ;;; TIME-GET-SYS-INFO -- Internal
276 ;;;
277 ;;; Return all the values that we want time to report.
278 ;;;
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 #+(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 #+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
301 #-(or pentium sparc-v9 ppc)
302 (defun cycle-count/float () 0.0)
303
304 (defvar *time-consing* nil)
305 (defvar *last-time-consing* nil)
306 (defvar *in-get-time-consing* nil)
307
308 (defun get-time-consing ()
309 (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
314
315 ;;; %TIME -- Internal
316 ;;;
317 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
318 ;;; function, report the times.
319 ;;;
320 (defun %time (fun)
321 (let ((fun (massage-time-function fun))
322 old-run-utime
323 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 cycle-count
334 page-faults-overhead
335 old-bytes-consed
336 new-bytes-consed
337 cons-overhead)
338 (get-time-consing)
339 ;; Calculate the overhead...
340 (multiple-value-setq
341 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
342 (time-get-sys-info))
343 ;; Do it a second time to make sure everything is faulted in.
344 (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 (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 (setq old-real-time (get-internal-real-time))
360 (multiple-value-setq
361 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
362 (time-get-sys-info))
363 (let ((start-gc-run-time *gc-run-time*))
364 (setq cycle-count (- (cycle-count/float)))
365 (multiple-value-prog1
366 ;; Execute the form and return its values.
367 (funcall fun)
368 (incf cycle-count (cycle-count/float))
369 (multiple-value-setq
370 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
371 (time-get-sys-info))
372 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
373 (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 (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 ~:D ~A cycles~% ~
384 ~@[[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 "CPU"
394 (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