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

Contents of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Thu Feb 20 00:59:18 1992 UTC (22 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.10: +22 -17 lines
Changed TIME to use *GC-RUN-TIME* to print the amount of time spent in GC.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/time.lisp,v 1.11 1992/02/20 00:59:18 ram Exp $")
11 ram 1.6 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the definitions for the Spice Lisp time functions.
15     ;;; They are mostly fairly straightforwardly implemented as calls to the
16     ;;; time server.
17     ;;;
18     ;;; Written by Rob MacLachlan.
19     ;;;
20     (in-package 'lisp)
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 wlott 1.4 (defconstant micro-seconds-per-internal-time-unit
30     (/ 1000000 internal-time-units-per-second))
31    
32    
33 ram 1.1 (defmacro not-leap-year (year)
34     (let ((sym (gensym)))
35     `(let ((,sym ,year))
36     (cond ((eq (mod ,sym 4) 0)
37     (and (eq (mod ,sym 100) 0)
38     (not (eq (mod ,sym 400) 0))))
39     (T T)))))
40    
41 ram 1.5
42     ;;; The base number of seconds for our internal "epoch". We initialize this to
43     ;;; the time of the first call to G-I-R-T, and then subtract this out of the
44     ;;; result.
45     ;;;
46     (defvar *internal-real-time-base-seconds* nil)
47     (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
48    
49 ram 1.1 ;;; Get-Internal-Real-Time -- Public
50     ;;;
51     (defun get-internal-real-time ()
52     "Return the real time in the internal time format. This is useful for
53     finding elapsed time. See Internal-Time-Units-Per-Second."
54 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
55 wlott 1.9 (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
56 wlott 1.10 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
57 ram 1.5 (let ((base *internal-real-time-base-seconds*)
58     (uint (truncate useconds
59     micro-seconds-per-internal-time-unit)))
60     (declare (type (unsigned-byte 32) uint))
61     (cond (base
62 wlott 1.10 (truly-the (unsigned-byte 32)
63     (+ (the (unsigned-byte 32)
64     (* (the (unsigned-byte 32) (- seconds base))
65     internal-time-units-per-second))
66     uint)))
67 ram 1.5 (t
68     (setq *internal-real-time-base-seconds* seconds)
69     uint))))))
70 ram 1.1
71 ram 1.5
72 ram 1.1 ;;; Get-Internal-Run-Time -- Public
73     ;;;
74     (defun get-internal-run-time ()
75     "Return the run time in the internal time format. This is useful for
76     finding CPU usage."
77 ram 1.5 (locally (declare (optimize (speed 3) (safety 0)))
78     (multiple-value-bind (ignore utime stime)
79 wlott 1.9 (unix:unix-getrusage unix:rusage_self)
80 ram 1.5 (declare (ignore ignore))
81     (values (truncate (the (unsigned-byte 32) (+ utime stime))
82     micro-seconds-per-internal-time-unit)))))
83 wlott 1.4
84 ram 1.1
85     ;;; Subtract from the returned Internal_Time to get the universal time.
86     ;;; The offset between our time base and the Perq one is 2145 weeks and
87     ;;; five days.
88     ;;;
89     (defconstant seconds-in-week (* 60 60 24 7))
90     (defconstant weeks-offset 2145)
91     (defconstant seconds-offset 432000)
92     (defconstant minutes-per-day (* 24 60))
93     (defconstant quarter-days-per-year (1+ (* 365 4)))
94     (defconstant quarter-days-per-century 146097)
95     (defconstant november-17-1858 678882)
96     (defconstant weekday-november-17-1858 2)
97     (defconstant unix-to-universal-time 2208988800)
98    
99     ;;; Make-Universal-Time -- Internal
100     ;;;
101     ;;; Convert a Unix Internal_Time into a universal time.
102     ;;;
103     (defun make-universal-time (weeks msec)
104     (+ (* (- weeks weeks-offset) seconds-in-week)
105     (- (truncate msec 1000) seconds-offset)))
106    
107 ram 1.3
108 ram 1.1 ;;; Get-Universal-Time -- Public
109     ;;;
110     ;;;
111     (defun get-universal-time ()
112     "Returns a single integer for the current time of
113     day in universal time format."
114 wlott 1.9 (multiple-value-bind (res secs) (unix:unix-gettimeofday)
115 ram 1.1 (declare (ignore res))
116     (+ secs unix-to-universal-time)))
117    
118     (defun get-decoded-time ()
119     "Returns nine values specifying the current time as follows:
120 ram 1.3 second, minute, hour, date, month, year, day of week (0 = Monday), T
121     (daylight savings times) or NIL (standard time), and timezone."
122 ram 1.1 (decode-universal-time (get-universal-time)))
123    
124     (defun decode-universal-time (universal-time &optional time-zone)
125 ram 1.3 "Converts a universal-time to decoded time format returning the following
126     nine values: second, minute, hour, date, month, year, day of week (0 =
127     Monday), T (daylight savings time) or NIL (standard time), and timezone.
128     Completely ignores daylight-savings-time when time-zone is supplied."
129 ram 1.1 (declare (type (or fixnum null) time-zone))
130     (multiple-value-bind (weeks secs)
131     (truncate (+ universal-time seconds-offset)
132     seconds-in-week)
133     (let ((weeks (+ weeks weeks-offset))
134     (second NIL)
135     (minute NIL)
136     (hour NIL)
137     (date NIL)
138     (month NIL)
139     (year NIL)
140     (day NIL)
141     (daylight NIL)
142     (timezone (if (null time-zone)
143     (multiple-value-bind (res s us tz)
144 wlott 1.9 (unix:unix-gettimeofday)
145 ram 1.1 (declare (ignore s us))
146     (if res tz 0))
147     (* time-zone 60))))
148     (declare (fixnum timezone))
149     (multiple-value-bind (t1 seconds) (truncate secs 60)
150     (setq second seconds)
151     (setq t1 (- t1 timezone))
152     (let* ((tday (if (< t1 0)
153     (1- (truncate (1+ t1) minutes-per-day))
154     (truncate t1 minutes-per-day))))
155     (multiple-value-setq (hour minute)
156     (truncate (- t1 (* tday minutes-per-day)) 60))
157     (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
158     (tcent (truncate t2 quarter-days-per-century)))
159     (setq t2 (mod t2 quarter-days-per-century))
160     (setq t2 (+ (- t2 (mod t2 4)) 3))
161     (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
162     (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
163     4))))
164     (setq day (mod (+ tday weekday-november-17-1858) 7))
165 ram 1.3 (unless time-zone
166     (if (setq daylight (dst-check days-since-mar0 hour day))
167     (cond ((eq hour 23)
168     (setq hour 0)
169     (setq day (mod (1+ day) 7))
170     (setq days-since-mar0 (1+ days-since-mar0))
171     (if (>= days-since-mar0 366)
172     (if (or (> days-since-mar0 366)
173     (not-leap-year (1+ year)))
174     (setq days-since-mar0 368))))
175     (T (setq hour (1+ hour))))))
176 ram 1.1 (let ((t3 (+ (* days-since-mar0 5) 456)))
177     (cond ((>= t3 1989)
178     (setq t3 (- t3 1836))
179     (setq year (1+ year))))
180     (multiple-value-setq (month t3) (truncate t3 153))
181     (setq date (1+ (truncate t3 5))))))))
182     (values second minute hour date month year day
183     daylight (truncate timezone 60)))))
184    
185     ;;; Encode-Universal-Time -- Public
186     ;;;
187     ;;; Just do a TimeUser:T_UserToInt. If the year is between 0 and 99 we
188     ;;; have to figure out which the "obvious" year is.
189     ;;;
190    
191     (defun encode-universal-time (second minute hour date month year
192     &optional time-zone)
193     "The time values specified in decoded format are converted to
194     universal time, which is returned."
195     (let* ((year (if (< year 100)
196     (multiple-value-bind (sec min hour day month now-year)
197     (get-decoded-time)
198     (declare (ignore sec min hour day month))
199     (do ((y (+ year (* 100 (1- (truncate now-year 100))))
200     (+ y 100)))
201     ((<= (abs (- y now-year)) 50) y)))
202     year))
203     (zone (if time-zone (* time-zone 60)
204 wlott 1.9 (multiple-value-bind (res s us tz) (unix:unix-gettimeofday)
205 ram 1.1 (declare (ignore s us))
206     (if res tz))))
207     (tmonth (- month 3)))
208     (cond ((< tmonth 0)
209     (setq tmonth (+ tmonth 12))
210     (setq year (1- year))))
211     (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
212     (multiple-value-bind (tcent tyear) (truncate year 100)
213     (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
214     (truncate (* tyear quarter-days-per-year) 4)
215     days-since-mar0)
216     november-17-1858))
217     (daylight (dst-check days-since-mar0 (1- hour)
218     (mod (+ tday weekday-november-17-1858) 7)))
219     (tminutes (+ (* hour 60) minute zone)))
220     (if daylight (setq tminutes (- tminutes 60)))
221     (do ((i tminutes (+ i minutes-per-day)))
222     ((>= i 0) (setq tminutes i))
223     (declare (fixnum i))
224     (decf tday 1))
225     (do ((i tminutes (- i minutes-per-day)))
226     ((< i minutes-per-day) (setq tminutes i))
227     (declare (fixnum i))
228     (incf tday 1))
229     (multiple-value-bind (weeks dpart) (truncate tday 7)
230     (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
231     tminutes) 60)
232     second) 1000))))))))
233    
234     ;;; Dst-check -- Internal
235     (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
236     (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
237    
238     (eval-when (compile eval)
239    
240     (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
241     (let ((d (gensym))
242     (h (gensym))
243     (w (gensym))
244     (db (gensym)))
245     `(let ((,d ,day)
246     (,h ,hour)
247     (,w ,weekday)
248     (,db ,daybound))
249     (declare (fixnum ,d ,h ,w ,db))
250     (cond ((< ,d ,db) NIL)
251     ((> (the fixnum (- ,d ,w)) ,db) T)
252     ((and (eq ,w 6) (> ,h 0)) T)
253     (T NIL)))))
254    
255     (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
256     (let ((d (gensym))
257     (h (gensym))
258     (w (gensym))
259     (db (gensym)))
260     `(let ((,d ,day)
261     (,h ,hour)
262     (,w ,weekday)
263     (,db ,daybound))
264     (declare (fixnum ,d ,h ,w ,db))
265     (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
266     ((> (the fixnum (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
267     ((and (eq ,w 6) (> ,h 0)) T)
268     (T NIL)))))
269     )
270    
271     (defun dst-check (day hour weekday)
272     (and (dst-check-start-of-month-ge day hour weekday april-1)
273     (not (dst-check-end-of-month-ge day hour weekday october-31))))
274    
275 ram 1.8 ;;;; Time:
276    
277 ram 1.1 (defmacro time (form)
278     "Evaluates the Form and prints timing information on *Trace-Output*."
279 ram 1.2 `(%time #'(lambda () ,form)))
280 ram 1.1
281 ram 1.7 ;;; MASSAGE-TIME-FUNCTION -- Internal
282     ;;;
283     ;;; Try to compile the closure arg to %TIME if it is interpreted.
284     ;;;
285     (defun massage-time-function (fun)
286     (cond
287     ((eval:interpreted-function-p fun)
288     (multiple-value-bind (def env-p)
289     (function-lambda-expression fun)
290     (declare (ignore def))
291     (cond
292     (env-p
293     (warn "TIME form in a non-null environment, forced to interpret.~@
294     Compiling entire form will produce more accurate times.")
295     fun)
296     (t
297     (compile nil fun)))))
298     (t fun)))
299    
300 ram 1.8 ;;; TIME-GET-SYS-INFO -- Internal
301     ;;;
302     ;;; Return all the files that we want time to report.
303     ;;;
304     (defun time-get-sys-info ()
305     (multiple-value-bind (user sys faults)
306     (system:get-system-info)
307     (values user sys faults (get-bytes-consed))))
308    
309     ;;; %TIME -- Internal
310     ;;;
311     ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
312     ;;; function, report the times.
313     ;;;
314 ram 1.2 (defun %time (fun)
315 ram 1.7 (let ((fun (massage-time-function fun))
316     old-run-utime
317 ram 1.8 new-run-utime
318     old-run-stime
319     new-run-stime
320     old-real-time
321     new-real-time
322     old-page-faults
323     new-page-faults
324     real-time-overhead
325     run-utime-overhead
326     run-stime-overhead
327     page-faults-overhead
328     old-bytes-consed
329     new-bytes-consed
330     cons-overhead)
331 ram 1.2 ;; Calculate the overhead...
332 ram 1.8 (multiple-value-setq
333     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
334     (time-get-sys-info))
335 ram 1.2 ;; Do it a second time to make sure everything is faulted in.
336 ram 1.8 (multiple-value-setq
337     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
338     (time-get-sys-info))
339     (multiple-value-setq
340     (new-run-utime new-run-stime new-page-faults new-bytes-consed)
341     (time-get-sys-info))
342 ram 1.2 (setq run-utime-overhead (- new-run-utime old-run-utime))
343     (setq run-stime-overhead (- new-run-stime old-run-stime))
344     (setq page-faults-overhead (- new-page-faults old-page-faults))
345     (setq old-real-time (get-internal-real-time))
346     (setq old-real-time (get-internal-real-time))
347     (setq new-real-time (get-internal-real-time))
348     (setq real-time-overhead (- new-real-time old-real-time))
349     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
350     ;; Now get the initial times.
351 ram 1.8 (multiple-value-setq
352     (old-run-utime old-run-stime old-page-faults old-bytes-consed)
353     (time-get-sys-info))
354 ram 1.2 (setq old-real-time (get-internal-real-time))
355 ram 1.11 (let ((start-gc-run-time *gc-run-time*))
356 ram 1.2 (multiple-value-prog1
357 ram 1.8 ;; Execute the form and return its values.
358     (funcall fun)
359     (multiple-value-setq
360 ram 1.11 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
361     (time-get-sys-info))
362 ram 1.2 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
363 ram 1.11 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
364     (format *trace-output*
365     "~&Evaluation took:~% ~
366     ~S second~:P of real time~% ~
367     ~S second~:P of user run time~% ~
368     ~S second~:P of system run time~% ~
369     ~:[~;[Run times include ~S second~:P GC run time]~% ~]~
370     ~S page fault~:P and~% ~
371     ~S bytes consed.~%"
372     (max (/ (- new-real-time old-real-time)
373     (float internal-time-units-per-second))
374     0.0)
375     (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
376     (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
377     (not (zerop gc-run-time))
378     (/ (float gc-run-time) (float internal-time-units-per-second))
379     (max (- new-page-faults old-page-faults) 0)
380     (max (- new-bytes-consed old-bytes-consed) 0)))))))

  ViewVC Help
Powered by ViewVC 1.1.5