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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (hide annotations)
Mon Apr 19 02:18:04 2010 UTC (4 years ago) by rtoy
Branch: MAIN
Changes since 1.31: +8 -8 lines
Remove _N"" reader macro from docstrings when possible.
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.32 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.32 2010/04/19 02:18:04 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 rtoy 1.31 (intl:textdomain "cmucl")
20    
21 ram 1.1 (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 rtoy 1.32 "The number of internal time units that fit into a second. See
27 ram 1.1 Get-Internal-Real-Time and Get-Internal-Run-Time.")
28    
29 wlott 1.4 (defconstant micro-seconds-per-internal-time-unit
30     (/ 1000000 internal-time-units-per-second))
31    
32    
33 ram 1.1
34 ram 1.5
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 ram 1.1 ;;; Get-Internal-Real-Time -- Public
43     ;;;
44     (defun get-internal-real-time ()
45 rtoy 1.32 "Return the real time in the internal time format. This is useful for
46 ram 1.1 finding elapsed time. See Internal-Time-Units-Per-Second."
47 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
48 wlott 1.9 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
49 wlott 1.10 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
50 ram 1.5 (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 wlott 1.10 (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 ram 1.5 (t
61     (setq *internal-real-time-base-seconds* seconds)
62     uint))))))
63 ram 1.1
64 ram 1.5
65 ram 1.1 ;;; Get-Internal-Run-Time -- Public
66     ;;;
67 dtc 1.18 #-(and sparc svr4)
68 ram 1.1 (defun get-internal-run-time ()
69 rtoy 1.31 _N"Return the run time in the internal time format. This is useful for
70 ram 1.1 finding CPU usage."
71 ram 1.13 (declare (values (unsigned-byte 32)))
72 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
73 ram 1.13 (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 dtc 1.18
84     ;;; Get-Internal-Run-Time -- Public
85     ;;;
86     #+(and sparc svr4)
87     (defun get-internal-run-time ()
88 rtoy 1.31 _N"Return the run time in the internal time format. This is useful for
89 dtc 1.18 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 wlott 1.4
98 ram 1.1
99 wlott 1.15 ;;;; Encode and Decode universal times.
100    
101     ;;; CURRENT-TIMEZONE -- internal.
102     ;;;
103     ;;; Returns two values:
104 rtoy 1.30 ;;; - the minutes west of GMT.
105 wlott 1.15 ;;; - 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 ram 1.1 ;;; 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 rtoy 1.32 "Returns a single integer for the current time of
133 ram 1.1 day in universal time format."
134 wlott 1.9 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
135 ram 1.1 (declare (ignore res))
136     (+ secs unix-to-universal-time)))
137    
138     (defun get-decoded-time ()
139 rtoy 1.32 "Returns nine values specifying the current time as follows:
140 ram 1.3 second, minute, hour, date, month, year, day of week (0 = Monday), T
141     (daylight savings times) or NIL (standard time), and timezone."
142 ram 1.1 (decode-universal-time (get-universal-time)))
143    
144 wlott 1.15
145 ram 1.1 (defun decode-universal-time (universal-time &optional time-zone)
146 rtoy 1.32 "Converts a universal-time to decoded time format returning the following
147 wlott 1.15 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 dtc 1.19 (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 ram 1.1
190 wlott 1.15
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 ram 1.17 (truncate (+ years 300) 400))))
205 wlott 1.15
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 ram 1.1 ;;; Encode-Universal-Time -- Public
216     ;;;
217     (defun encode-universal-time (second minute hour date month year
218     &optional time-zone)
219 rtoy 1.32 "The time values specified in decoded format are converted to
220 ram 1.1 universal time, which is returned."
221 wlott 1.15 (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 ram 1.1 (let* ((year (if (< year 100)
229 wlott 1.15 (pick-obvious-year year)
230 ram 1.1 year))
231 wlott 1.15 (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 ram 1.1
251    
252 ram 1.8 ;;;; Time:
253    
254 ram 1.1 (defmacro time (form)
255 rtoy 1.32 "Evaluates the Form and prints timing information on *Trace-Output*."
256 ram 1.2 `(%time #'(lambda () ,form)))
257 ram 1.1
258 ram 1.7 ;;; 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 rtoy 1.31 (warn _"TIME form in a non-null environment, forced to interpret.~@
271 ram 1.7 Compiling entire form will produce more accurate times.")
272     fun)
273     (t
274     (compile nil fun)))))
275     (t fun)))
276    
277 ram 1.8 ;;; TIME-GET-SYS-INFO -- Internal
278     ;;;
279 cracauer 1.20 ;;; Return all the values that we want time to report.
280 ram 1.8 ;;;
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 rtoy 1.28 #+(or pentium sparc-v9)
287 emarsden 1.22 (defun cycle-count/float ()
288     (multiple-value-bind (lo hi)
289     (vm::read-cycle-counter)
290     (+ (* hi (expt 2.0d0 32)) lo)))
291 rtoy 1.28 #+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 emarsden 1.22
303 rtoy 1.26 #-(or pentium sparc-v9 ppc)
304 emarsden 1.22 (defun cycle-count/float () 0.0)
305    
306 gerd 1.24 (defvar *time-consing* nil)
307     (defvar *last-time-consing* nil)
308 gerd 1.25 (defvar *in-get-time-consing* nil)
309 gerd 1.24
310     (defun get-time-consing ()
311 gerd 1.25 (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 gerd 1.24
316 emarsden 1.22
317 ram 1.8 ;;; %TIME -- Internal
318     ;;;
319     ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
320     ;;; function, report the times.
321     ;;;
322 rtoy 1.29 (defun %time (fun)
323 ram 1.7 (let ((fun (massage-time-function fun))
324     old-run-utime
325 ram 1.8 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 emarsden 1.22 cycle-count
336 ram 1.8 page-faults-overhead
337     old-bytes-consed
338     new-bytes-consed
339     cons-overhead)
340 gerd 1.24 (get-time-consing)
341 ram 1.2 ;; Calculate the overhead...
342 ram 1.8 (multiple-value-setq
343     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
344     (time-get-sys-info))
345 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
346 ram 1.8 (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 ram 1.2 (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 cracauer 1.20 (setq old-real-time (get-internal-real-time))
362 ram 1.8 (multiple-value-setq
363     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
364     (time-get-sys-info))
365 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
366 emarsden 1.22 (setq cycle-count (- (cycle-count/float)))
367 ram 1.2 (multiple-value-prog1
368 ram 1.8 ;; Execute the form and return its values.
369     (funcall fun)
370 emarsden 1.22 (incf cycle-count (cycle-count/float))
371 ram 1.8 (multiple-value-setq
372 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
373     (time-get-sys-info))
374 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
375 gerd 1.24 (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 gerd 1.25 (unless *in-get-time-consing*
378     (terpri *trace-output*)
379     (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
380     (format *trace-output*
381 rtoy 1.31 _"Evaluation took:~% ~
382     ~S seconds of real time~% ~
383     ~S seconds of user run time~% ~
384     ~S seconds of system run time~% "
385 gerd 1.25 (max (/ (- new-real-time old-real-time)
386     (float internal-time-units-per-second))
387     0.0)
388     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
389 rtoy 1.31 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0))
390     (format *trace-output*
391     (intl:ngettext
392     "~:D ~A cycle~% ~
393     ~@[[Run times include ~S seconds GC run time]~% ~]"
394     "~:D ~A cycles~% ~
395     ~@[[Run times include ~S seconds GC run time]~% ~]"
396     (truncate cycle-count))
397 gerd 1.25 (truncate cycle-count)
398 rtoy 1.28 "CPU"
399 gerd 1.25 (unless (zerop gc-run-time)
400     (/ (float gc-run-time)
401 rtoy 1.31 (float internal-time-units-per-second))))
402     (format *trace-output*
403     (intl:ngettext "~S page fault and~% "
404     "~S page faults and~% "
405     (max (- new-page-faults old-page-faults) 0))
406     (max (- new-page-faults old-page-faults) 0))
407     (format *trace-output*
408     (intl:ngettext "~:D byte consed.~%"
409     "~:D bytes consed.~%"
410     (max (- bytes-consed (or *time-consing* 0)) 0))
411 gerd 1.25 (max (- bytes-consed (or *time-consing* 0)) 0)))
412     (terpri *trace-output*))
413     (setq *last-time-consing* bytes-consed))))))

  ViewVC Help
Powered by ViewVC 1.1.5