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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30.10.1 - (show annotations)
Mon Feb 8 17:15:49 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
Changes since 1.30: +3 -1 lines
Add (intl:textdomain "cmucl") to the files to set the textdomain.
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.10.1 2010/02/08 17:15:49 rtoy Exp $")
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 (intl:textdomain "cmucl")
20
21 (export '(internal-time-units-per-second get-internal-real-time
22 get-internal-run-time get-universal-time
23 get-decoded-time encode-universal-time decode-universal-time))
24
25 (defconstant internal-time-units-per-second 100
26 "The number of internal time units that fit into a second. See
27 Get-Internal-Real-Time and Get-Internal-Run-Time.")
28
29 (defconstant micro-seconds-per-internal-time-unit
30 (/ 1000000 internal-time-units-per-second))
31
32
33
34
35 ;;; The base number of seconds for our internal "epoch". We initialize this to
36 ;;; the time of the first call to G-I-R-T, and then subtract this out of the
37 ;;; result.
38 ;;;
39 (defvar *internal-real-time-base-seconds* nil)
40 (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
41
42 ;;; Get-Internal-Real-Time -- Public
43 ;;;
44 (defun get-internal-real-time ()
45 "Return the real time in the internal time format. This is useful for
46 finding elapsed time. See Internal-Time-Units-Per-Second."
47 (locally (declare (optimize (speed 3) (safety 0)))
48 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
49 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
50 (let ((base *internal-real-time-base-seconds*)
51 (uint (truncate useconds
52 micro-seconds-per-internal-time-unit)))
53 (declare (type (unsigned-byte 32) uint))
54 (cond (base
55 (truly-the (unsigned-byte 32)
56 (+ (the (unsigned-byte 32)
57 (* (the (unsigned-byte 32) (- seconds base))
58 internal-time-units-per-second))
59 uint)))
60 (t
61 (setq *internal-real-time-base-seconds* seconds)
62 uint))))))
63
64
65 ;;; Get-Internal-Run-Time -- Public
66 ;;;
67 #-(and sparc svr4)
68 (defun get-internal-run-time ()
69 "Return the run time in the internal time format. This is useful for
70 finding CPU usage."
71 (declare (values (unsigned-byte 32)))
72 (locally (declare (optimize (speed 3) (safety 0)))
73 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
74 (unix:unix-fast-getrusage unix:rusage_self)
75 (declare (ignore ignore)
76 (type (unsigned-byte 31) utime-sec stime-sec)
77 (type (mod 1000000) utime-usec stime-usec))
78 (+ (the (unsigned-byte 32)
79 (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
80 internal-time-units-per-second))
81 (truncate (+ utime-usec stime-usec)
82 micro-seconds-per-internal-time-unit)))))
83
84 ;;; Get-Internal-Run-Time -- Public
85 ;;;
86 #+(and sparc svr4)
87 (defun get-internal-run-time ()
88 "Return the run time in the internal time format. This is useful for
89 finding CPU usage."
90 (declare (values (unsigned-byte 32)))
91 (locally (declare (optimize (speed 3) (safety 0)))
92 (multiple-value-bind (ignore utime stime cutime cstime)
93 (unix:unix-times)
94 (declare (ignore ignore cutime cstime)
95 (type (unsigned-byte 31) utime stime))
96 (the (unsigned-byte 32) (+ utime stime)))))
97
98
99 ;;;; Encode and Decode universal times.
100
101 ;;; CURRENT-TIMEZONE -- internal.
102 ;;;
103 ;;; Returns two values:
104 ;;; - the minutes west of GMT.
105 ;;; - T if daylight savings is in effect, NIL if not.
106 ;;;
107 (alien:def-alien-routine get-timezone c-call:void
108 (when c-call:long :in)
109 (minutes-west c-call:int :out)
110 (daylight-savings-p alien:boolean :out))
111
112
113 ;;; Subtract from the returned Internal_Time to get the universal time.
114 ;;; The offset between our time base and the Perq one is 2145 weeks and
115 ;;; five days.
116 ;;;
117 (defconstant seconds-in-week (* 60 60 24 7))
118 (defconstant weeks-offset 2145)
119 (defconstant seconds-offset 432000)
120 (defconstant minutes-per-day (* 24 60))
121 (defconstant quarter-days-per-year (1+ (* 365 4)))
122 (defconstant quarter-days-per-century 146097)
123 (defconstant november-17-1858 678882)
124 (defconstant weekday-november-17-1858 2)
125 (defconstant unix-to-universal-time 2208988800)
126
127
128 ;;; Get-Universal-Time -- Public
129 ;;;
130 ;;;
131 (defun get-universal-time ()
132 "Returns a single integer for the current time of
133 day in universal time format."
134 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
135 (declare (ignore res))
136 (+ secs unix-to-universal-time)))
137
138 (defun get-decoded-time ()
139 "Returns nine values specifying the current time as follows:
140 second, minute, hour, date, month, year, day of week (0 = Monday), T
141 (daylight savings times) or NIL (standard time), and timezone."
142 (decode-universal-time (get-universal-time)))
143
144
145 (defun decode-universal-time (universal-time &optional time-zone)
146 "Converts a universal-time to decoded time format returning the following
147 nine values: second, minute, hour, date, month, year, day of week (0 =
148 Monday), T (daylight savings time) or NIL (standard time), and timezone.
149 Completely ignores daylight-savings-time when time-zone is supplied."
150 (multiple-value-bind (daylight timezone)
151 (if time-zone
152 (values nil (* time-zone 60 60))
153 (multiple-value-bind
154 (ignore minwest dst)
155 (get-timezone (- universal-time unix-to-universal-time))
156 (declare (ignore ignore))
157 (values dst (* minwest 60))))
158 (declare (fixnum timezone))
159 (multiple-value-bind (weeks secs)
160 (truncate (+ (- universal-time timezone) seconds-offset)
161 seconds-in-week)
162 (let ((weeks (+ weeks weeks-offset)))
163 (multiple-value-bind (t1 second)
164 (truncate secs 60)
165 (let ((tday (truncate t1 minutes-per-day)))
166 (multiple-value-bind (hour minute)
167 (truncate (- t1 (* tday minutes-per-day)) 60)
168 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
169 (tcent (truncate t2 quarter-days-per-century)))
170 (setq t2 (mod t2 quarter-days-per-century))
171 (setq t2 (+ (- t2 (mod t2 4)) 3))
172 (let* ((year (+ (* tcent 100)
173 (truncate t2 quarter-days-per-year)))
174 (days-since-mar0
175 (1+ (truncate (mod t2 quarter-days-per-year) 4)))
176 (day (mod (+ tday weekday-november-17-1858) 7))
177 (t3 (+ (* days-since-mar0 5) 456)))
178 (cond ((>= t3 1989)
179 (setq t3 (- t3 1836))
180 (setq year (1+ year))))
181 (multiple-value-bind (month t3)
182 (truncate t3 153)
183 (let ((date (1+ (truncate t3 5))))
184 (values second minute hour date month year day
185 daylight
186 (if daylight
187 (1+ (/ timezone 60 60))
188 (/ timezone 60 60))))))))))))))
189
190
191 (defun pick-obvious-year (year)
192 (declare (type (mod 100) year))
193 (let* ((current-year (nth-value 5 (get-decoded-time)))
194 (guess (+ year (* (truncate (- current-year 50) 100) 100))))
195 (declare (type (integer 1900 9999) current-year guess))
196 (if (> (- current-year guess) 50)
197 (+ guess 100)
198 guess)))
199
200 (defun leap-years-before (year)
201 (let ((years (- year 1901)))
202 (+ (- (truncate years 4)
203 (truncate years 100))
204 (truncate (+ years 300) 400))))
205
206 (defvar *days-before-month*
207 (collect ((results))
208 (results nil)
209 (let ((sum 0))
210 (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
211 (results sum)
212 (incf sum days-per-month)))
213 (coerce (results) 'vector)))
214
215 ;;; Encode-Universal-Time -- Public
216 ;;;
217 (defun encode-universal-time (second minute hour date month year
218 &optional time-zone)
219 "The time values specified in decoded format are converted to
220 universal time, which is returned."
221 (declare (type (mod 60) second)
222 (type (mod 60) minute)
223 (type (mod 24) hour)
224 (type (integer 1 31) date)
225 (type (integer 1 12) month)
226 (type (or (integer 0 99) (integer 1900)) year)
227 (type (or null rational) time-zone))
228 (let* ((year (if (< year 100)
229 (pick-obvious-year year)
230 year))
231 (days (+ (1- date)
232 (aref *days-before-month* month)
233 (if (> month 2)
234 (leap-years-before (1+ year))
235 (leap-years-before year))
236 (* (- year 1900) 365)))
237 (hours (+ hour (* days 24))))
238 (if time-zone
239 (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
240 (let* ((minwest-guess
241 (nth-value 1
242 (get-timezone (- (* hours 60 60)
243 unix-to-universal-time))))
244 (guess (+ minute (* hours 60) minwest-guess))
245 (minwest
246 (nth-value 1
247 (get-timezone (- (* guess 60)
248 unix-to-universal-time)))))
249 (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
250
251
252 ;;;; Time:
253
254 (defmacro time (form)
255 "Evaluates the Form and prints timing information on *Trace-Output*."
256 `(%time #'(lambda () ,form)))
257
258 ;;; MASSAGE-TIME-FUNCTION -- Internal
259 ;;;
260 ;;; Try to compile the closure arg to %TIME if it is interpreted.
261 ;;;
262 (defun massage-time-function (fun)
263 (cond
264 ((eval:interpreted-function-p fun)
265 (multiple-value-bind (def env-p)
266 (function-lambda-expression fun)
267 (declare (ignore def))
268 (cond
269 (env-p
270 (warn "TIME form in a non-null environment, forced to interpret.~@
271 Compiling entire form will produce more accurate times.")
272 fun)
273 (t
274 (compile nil fun)))))
275 (t fun)))
276
277 ;;; TIME-GET-SYS-INFO -- Internal
278 ;;;
279 ;;; Return all the values that we want time to report.
280 ;;;
281 (defun time-get-sys-info ()
282 (multiple-value-bind (user sys faults)
283 (system:get-system-info)
284 (values user sys faults (get-bytes-consed))))
285
286 #+(or pentium sparc-v9)
287 (defun cycle-count/float ()
288 (multiple-value-bind (lo hi)
289 (vm::read-cycle-counter)
290 (+ (* hi (expt 2.0d0 32)) lo)))
291 #+ppc
292 (progn
293 (alien:def-alien-variable cycles-per-tick c-call:int)
294 (defun cycle-count/float ()
295 (multiple-value-bind (lo hi)
296 (vm::read-cycle-counter)
297 ;; The cycle counter on PPC isn't really a cycle counter. It
298 ;; counts ticks, so we need to convert ticks to cycles.
299 ;; CYCLES-PER-TICK is the scale factor, computed in C.
300 (* cycles-per-tick (+ (* hi (expt 2.0d0 32)) lo))))
301 )
302
303 #-(or pentium sparc-v9 ppc)
304 (defun cycle-count/float () 0.0)
305
306 (defvar *time-consing* nil)
307 (defvar *last-time-consing* nil)
308 (defvar *in-get-time-consing* nil)
309
310 (defun get-time-consing ()
311 (when (and (null *time-consing*) (not *in-get-time-consing*))
312 (let ((*in-get-time-consing* t))
313 (time nil)
314 (setq *time-consing* *last-time-consing*))))
315
316
317 ;;; %TIME -- Internal
318 ;;;
319 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
320 ;;; function, report the times.
321 ;;;
322 (defun %time (fun)
323 (let ((fun (massage-time-function fun))
324 old-run-utime
325 new-run-utime
326 old-run-stime
327 new-run-stime
328 old-real-time
329 new-real-time
330 old-page-faults
331 new-page-faults
332 real-time-overhead
333 run-utime-overhead
334 run-stime-overhead
335 cycle-count
336 page-faults-overhead
337 old-bytes-consed
338 new-bytes-consed
339 cons-overhead)
340 (get-time-consing)
341 ;; Calculate the overhead...
342 (multiple-value-setq
343 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
344 (time-get-sys-info))
345 ;; Do it a second time to make sure everything is faulted in.
346 (multiple-value-setq
347 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
348 (time-get-sys-info))
349 (multiple-value-setq
350 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
351 (time-get-sys-info))
352 (setq run-utime-overhead (- new-run-utime old-run-utime))
353 (setq run-stime-overhead (- new-run-stime old-run-stime))
354 (setq page-faults-overhead (- new-page-faults old-page-faults))
355 (setq old-real-time (get-internal-real-time))
356 (setq old-real-time (get-internal-real-time))
357 (setq new-real-time (get-internal-real-time))
358 (setq real-time-overhead (- new-real-time old-real-time))
359 (setq cons-overhead (- new-bytes-consed old-bytes-consed))
360 ;; Now get the initial times.
361 (setq old-real-time (get-internal-real-time))
362 (multiple-value-setq
363 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
364 (time-get-sys-info))
365 (let ((start-gc-run-time *gc-run-time*))
366 (setq cycle-count (- (cycle-count/float)))
367 (multiple-value-prog1
368 ;; Execute the form and return its values.
369 (funcall fun)
370 (incf cycle-count (cycle-count/float))
371 (multiple-value-setq
372 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
373 (time-get-sys-info))
374 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
375 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))
376 (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead)))
377 (unless *in-get-time-consing*
378 (terpri *trace-output*)
379 (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
380 (format *trace-output*
381 "Evaluation took:~% ~
382 ~S second~:P of real time~% ~
383 ~S second~:P of user run time~% ~
384 ~S second~:P of system run time~% ~
385 ~:D ~A cycles~% ~
386 ~@[[Run times include ~S second~:P GC run time]~% ~]~
387 ~S page fault~:P and~% ~
388 ~:D bytes consed.~%"
389 (max (/ (- new-real-time old-real-time)
390 (float internal-time-units-per-second))
391 0.0)
392 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
393 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
394 (truncate cycle-count)
395 "CPU"
396 (unless (zerop gc-run-time)
397 (/ (float gc-run-time)
398 (float internal-time-units-per-second)))
399 (max (- new-page-faults old-page-faults) 0)
400 (max (- bytes-consed (or *time-consing* 0)) 0)))
401 (terpri *trace-output*))
402 (setq *last-time-consing* bytes-consed))))))

  ViewVC Help
Powered by ViewVC 1.1.5