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

Diff of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3.1.3 by wlott, Thu Jul 19 18:42:05 1990 UTC revision 1.33 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-  ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;;
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  (ext:file-comment
8      "$Header$")
9    ;;;
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;;    This file contains the definitions for the Spice Lisp time functions.  ;;;    This file contains the definitions for the Spice Lisp time functions.
# Line 13  Line 15 
15  ;;;  ;;;
16  ;;;    Written by Rob MacLachlan.  ;;;    Written by Rob MacLachlan.
17  ;;;  ;;;
18  (in-package 'lisp)  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(internal-time-units-per-second get-internal-real-time  (export '(internal-time-units-per-second get-internal-real-time
22            get-internal-run-time get-universal-time            get-internal-run-time get-universal-time
23            get-decoded-time encode-universal-time decode-universal-time))            get-decoded-time encode-universal-time decode-universal-time))
# Line 26  Line 30 
30    (/ 1000000 internal-time-units-per-second))    (/ 1000000 internal-time-units-per-second))
31    
32    
 (defmacro not-leap-year (year)  
   (let ((sym (gensym)))  
     `(let ((,sym ,year))  
        (cond ((eq (mod ,sym 4) 0)  
               (and (eq (mod ,sym 100) 0)  
                    (not (eq (mod ,sym 400) 0))))  
              (T T)))))  
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  ;;; Get-Internal-Real-Time  --  Public
43  ;;;  ;;;
44  (defun get-internal-real-time ()  (defun get-internal-real-time ()
45    "Return the real time in the internal time format.  This is useful for    "Return the real time in the internal time format.  This is useful for
46    finding elapsed time.  See Internal-Time-Units-Per-Second."    finding elapsed time.  See Internal-Time-Units-Per-Second."
47    (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)    (locally (declare (optimize (speed 3) (safety 0)))
48      (if result      (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
49          (+ (* seconds internal-time-units-per-second)        (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
50             (truncate useconds micro-seconds-per-internal-time-unit))        (let ((base *internal-real-time-base-seconds*)
51          (error "Unix system call gettimeofday failed: ~A"              (uint (truncate useconds
52                 (mach:get-unix-error-msg seconds)))))                              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  ;;; Get-Internal-Run-Time  --  Public
66  ;;;  ;;;
67    #-(and sparc svr4)
68  (defun get-internal-run-time ()  (defun get-internal-run-time ()
69    "Return the run time in the internal time format.  This is useful for    _N"Return the run time in the internal time format.  This is useful for
70    finding CPU usage."    finding CPU usage."
71    (multiple-value-bind (result utime stime)    (declare (values (unsigned-byte 32)))
72                         (mach:unix-getrusage mach:rusage_self)    (locally (declare (optimize (speed 3) (safety 0)))
73      (if result      (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
74          (values (truncate (+ utime stime)                           (unix:unix-fast-getrusage unix:rusage_self)
75                            micro-seconds-per-internal-time-unit))        (declare (ignore ignore)
76          (error "Unix system call getrusage failed: ~A"                 (type (unsigned-byte 31) utime-sec stime-sec)
77                 (mach:get-unix-error-msg utime)))))                 (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      _N"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.  ;;; 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  ;;; The offset between our time base and the Perq one is 2145 weeks and
115  ;;; five days.  ;;; five days.
# Line 74  Line 124 
124  (defconstant weekday-november-17-1858 2)  (defconstant weekday-november-17-1858 2)
125  (defconstant unix-to-universal-time 2208988800)  (defconstant unix-to-universal-time 2208988800)
126    
 ;;; Make-Universal-Time  --  Internal  
 ;;;  
 ;;;    Convert a Unix Internal_Time into a universal time.  
 ;;;  
 (defun make-universal-time (weeks msec)  
   (+ (* (- weeks weeks-offset) seconds-in-week)  
      (- (truncate msec 1000) seconds-offset)))  
   
127    
128  ;;; Get-Universal-Time  --  Public  ;;; Get-Universal-Time  --  Public
129  ;;;  ;;;
# Line 89  Line 131 
131  (defun get-universal-time ()  (defun get-universal-time ()
132    "Returns a single integer for the current time of    "Returns a single integer for the current time of
133     day in universal time format."     day in universal time format."
134    (multiple-value-bind (res secs) (mach:unix-gettimeofday)    (multiple-value-bind (res secs) (unix:unix-gettimeofday)
135      (declare (ignore res))      (declare (ignore res))
136      (+ secs unix-to-universal-time)))      (+ secs unix-to-universal-time)))
137    
# Line 99  Line 141 
141     (daylight savings times) or NIL (standard time), and timezone."     (daylight savings times) or NIL (standard time), and timezone."
142    (decode-universal-time (get-universal-time)))    (decode-universal-time (get-universal-time)))
143    
144    
145  (defun decode-universal-time (universal-time &optional time-zone)  (defun decode-universal-time (universal-time &optional time-zone)
146    "Converts a universal-time to decoded time format returning the following    "Converts a universal-time to decoded time format returning the following
147    nine values: second, minute, hour, date, month, year, day of week (0 =     nine values: second, minute, hour, date, month, year, day of week (0 =
148    Monday), T (daylight savings time) or NIL (standard time), and timezone.     Monday), T (daylight savings time) or NIL (standard time), and timezone.
149    Completely ignores daylight-savings-time when time-zone is supplied."     Completely ignores daylight-savings-time when time-zone is supplied."
150    (declare (type (or fixnum null) time-zone))    (multiple-value-bind (daylight timezone)
151    (multiple-value-bind (weeks secs)        (if time-zone
152                         (truncate (+ universal-time seconds-offset)            (values nil (* time-zone 60 60))
153                                   seconds-in-week)            (multiple-value-bind
154      (let ((weeks (+ weeks weeks-offset))                  (ignore minwest dst)
155            (second NIL)                (get-timezone (- universal-time unix-to-universal-time))
156            (minute NIL)              (declare (ignore ignore))
157            (hour NIL)              (values dst (* minwest 60))))
158            (date NIL)      (declare (fixnum timezone))
159            (month NIL)      (multiple-value-bind (weeks secs)
160            (year NIL)          (truncate (+ (- universal-time timezone) seconds-offset)
161            (day NIL)                    seconds-in-week)
162            (daylight NIL)        (let ((weeks (+ weeks weeks-offset)))
163            (timezone (if (null time-zone)          (multiple-value-bind (t1 second)
164                          (multiple-value-bind (res s us tz)              (truncate secs 60)
165                                               (mach:unix-gettimeofday)            (let ((tday (truncate t1 minutes-per-day)))
166                            (declare (ignore s us))              (multiple-value-bind (hour minute)
167                            (if res tz 0))                  (truncate (- t1 (* tday minutes-per-day)) 60)
168                          (* time-zone 60))))                (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
169        (declare (fixnum timezone))                       (tcent (truncate t2 quarter-days-per-century)))
170        (multiple-value-bind (t1 seconds) (truncate secs 60)                  (setq t2 (mod t2 quarter-days-per-century))
171          (setq second seconds)                  (setq t2 (+ (- t2 (mod t2 4)) 3))
172          (setq t1 (- t1 timezone))                  (let* ((year (+ (* tcent 100)
173          (let* ((tday (if (< t1 0)                                  (truncate t2 quarter-days-per-year)))
174                           (1- (truncate (1+ t1) minutes-per-day))                         (days-since-mar0
175                           (truncate t1 minutes-per-day))))                          (1+ (truncate (mod t2 quarter-days-per-year) 4)))
176            (multiple-value-setq (hour minute)                         (day (mod (+ tday weekday-november-17-1858) 7))
177              (truncate (- t1 (* tday minutes-per-day)) 60))                         (t3 (+ (* days-since-mar0 5) 456)))
178            (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))                    (cond ((>= t3 1989)
179                   (tcent (truncate t2 quarter-days-per-century)))                           (setq t3 (- t3 1836))
180              (setq t2 (mod t2 quarter-days-per-century))                           (setq year (1+ year))))
181              (setq t2 (+ (- t2 (mod t2 4)) 3))                    (multiple-value-bind (month t3)
182              (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))                        (truncate t3 153)
183              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)                      (let ((date (1+ (truncate t3 5))))
184                                                   4))))                        (values second minute hour date month year day
185                (setq day (mod (+ tday weekday-november-17-1858) 7))                                daylight
186                (unless time-zone                                (if daylight
187                  (if (setq daylight (dst-check days-since-mar0 hour day))                                    (1+ (/ timezone 60 60))
188                      (cond ((eq hour 23)                                    (/ timezone 60 60))))))))))))))
189                             (setq hour 0)  
190                             (setq day (mod (1+ day) 7))  
191                             (setq days-since-mar0 (1+ days-since-mar0))  (defun pick-obvious-year (year)
192                             (if (>= days-since-mar0 366)    (declare (type (mod 100) year))
193                                 (if (or (> days-since-mar0 366)    (let* ((current-year (nth-value 5 (get-decoded-time)))
194                                         (not-leap-year (1+ year)))           (guess (+ year (* (truncate (- current-year 50) 100) 100))))
195                                     (setq days-since-mar0 368))))      (declare (type (integer 1900 9999) current-year guess))
196                            (T (setq hour (1+ hour))))))      (if (> (- current-year guess) 50)
197                (let ((t3 (+ (* days-since-mar0 5) 456)))          (+ guess 100)
198                  (cond ((>= t3 1989)          guess)))
199                         (setq t3 (- t3 1836))  
200                         (setq year (1+ year))))  (defun leap-years-before (year)
201                  (multiple-value-setq (month t3) (truncate t3 153))    (let ((years (- year 1901)))
202                  (setq date (1+ (truncate t3 5))))))))      (+ (- (truncate years 4)
203        (values second minute hour date month year day            (truncate years 100))
204                daylight (truncate timezone 60)))))         (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  ;;; Encode-Universal-Time  --  Public
216  ;;;  ;;;
 ;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we  
 ;;; have to figure out which the "obvious" year is.  
 ;;;  
   
217  (defun encode-universal-time (second minute hour date month year  (defun encode-universal-time (second minute hour date month year
218                                       &optional time-zone)                                       &optional time-zone)
219    "The time values specified in decoded format are converted to    "The time values specified in decoded format are converted to
220     universal time, which is returned."     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)    (let* ((year (if (< year 100)
229                     (multiple-value-bind (sec min hour day month now-year)                     (pick-obvious-year year)
                                         (get-decoded-time)  
                      (declare (ignore sec min hour day month))  
                      (do ((y (+ year (* 100 (1- (truncate now-year 100))))  
                              (+ y 100)))  
                          ((<= (abs (- y now-year)) 50) y)))  
230                     year))                     year))
231           (zone (if time-zone (* time-zone 60)           (days (+ (1- date)
232                     (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)                    (aref *days-before-month* month)
233                       (declare (ignore s us))                    (if (> month 2)
234                       (if res tz))))                        (leap-years-before (1+ year))
235           (tmonth (- month 3)))                        (leap-years-before year))
236      (cond ((< tmonth 0)                    (* (- year 1900) 365)))
237             (setq tmonth (+ tmonth 12))           (hours (+ hour (* days 24))))
238             (setq year (1- year))))      (if time-zone
239      (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))          (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
240        (multiple-value-bind (tcent tyear) (truncate year 100)          (let* ((minwest-guess
241          (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)                  (nth-value 1
242                             (truncate (* tyear quarter-days-per-year) 4)                             (get-timezone (- (* hours 60 60)
243                             days-since-mar0)                                              unix-to-universal-time))))
244                          november-17-1858))                 (guess (+ minute (* hours 60) minwest-guess))
245                 (daylight (dst-check days-since-mar0 (1- hour)                 (minwest
246                                      (mod (+ tday weekday-november-17-1858) 7)))                  (nth-value 1
247                 (tminutes (+ (* hour 60) minute zone)))                             (get-timezone (- (* guess 60)
248            (if daylight (setq tminutes (- tminutes 60)))                                              unix-to-universal-time)))))
249            (do ((i tminutes (+ i minutes-per-day)))            (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
250                ((>= i 0) (setq tminutes i))  
             (declare (fixnum i))  
             (decf tday 1))  
           (do ((i tminutes (- i minutes-per-day)))  
               ((< i minutes-per-day) (setq tminutes i))  
             (declare (fixnum i))  
             (incf tday 1))  
           (multiple-value-bind (weeks dpart) (truncate tday 7)  
             (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)  
                                                    tminutes) 60)  
                                              second) 1000))))))))  
   
 ;;; Dst-check -- Internal  
 (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))  
 (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))  
   
 (eval-when (compile eval)  
   
   (defmacro dst-check-start-of-month-ge (day hour weekday daybound)  
     (let ((d (gensym))  
           (h (gensym))  
           (w (gensym))  
           (db (gensym)))  
       `(let ((,d ,day)  
              (,h ,hour)  
              (,w ,weekday)  
              (,db ,daybound))  
          (declare (fixnum ,d ,h ,w ,db))  
          (cond ((< ,d ,db) NIL)  
                ((> (the fixnum (- ,d ,w)) ,db) T)  
                ((and (eq ,w 6) (> ,h 0)) T)  
                (T NIL)))))  
   
   (defmacro dst-check-end-of-month-ge (day hour weekday daybound)  
     (let ((d (gensym))  
           (h (gensym))  
           (w (gensym))  
           (db (gensym)))  
       `(let ((,d ,day)  
              (,h ,hour)  
              (,w ,weekday)  
              (,db ,daybound))  
          (declare (fixnum ,d ,h ,w ,db))  
          (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)  
                ((> (the fixnum  (- (the fixnum (+ ,d 6)) ,w)) ,db) T)  
                ((and (eq ,w 6) (> ,h 0)) T)  
                (T NIL)))))  
   )  
   
 (defun dst-check (day hour weekday)  
   (and (dst-check-start-of-month-ge day hour weekday april-1)  
        (not (dst-check-end-of-month-ge day hour weekday october-31))))  
251    
252    ;;;; Time:
253    
254  (defmacro time (form)  (defmacro time (form)
255    "Evaluates the Form and prints timing information on *Trace-Output*."    "Evaluates the Form and prints timing information on *Trace-Output*."
256    `(%time #'(lambda () ,form)))    `(%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 (intl:gettext "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)  (defun %time (fun)
323    (let (old-run-utime    (let ((fun (massage-time-function fun))
324          new-run-utime          old-run-utime
325          old-run-stime          new-run-utime
326          new-run-stime          old-run-stime
327          old-real-time          new-run-stime
328          new-real-time          old-real-time
329          old-page-faults          new-real-time
330          new-page-faults          old-page-faults
331          real-time-overhead          new-page-faults
332          run-utime-overhead          real-time-overhead
333          run-stime-overhead          run-utime-overhead
334          page-faults-overhead          run-stime-overhead
335          old-bytes-consed          cycle-count
336          new-bytes-consed          page-faults-overhead
337          cons-overhead)          old-bytes-consed
338            new-bytes-consed
339            cons-overhead)
340        (get-time-consing)
341      ;; Calculate the overhead...      ;; Calculate the overhead...
342      (multiple-value-bind (err? utime stime)      (multiple-value-setq
343                           (mach:unix-getrusage mach:rusage_self)          (old-run-utime old-run-stime old-page-faults old-bytes-consed)
344        (cond ((null err?)        (time-get-sys-info))
              (error "Unix system call getrusage failed: ~A."  
                     (mach:get-unix-error-msg utime)))  
             (T (setq old-run-utime utime)  
                (setq old-run-stime stime))))  
     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)  
                          (mach:vm_statistics *task-self*)  
       (declare (ignore ps fc ac ic wc zf ra in ot))  
       (gr-error 'mach:vm_allocate gr)  
       (setq old-page-faults pf))  
     (setq old-bytes-consed (get-bytes-consed))  
345      ;; Do it a second time to make sure everything is faulted in.      ;; Do it a second time to make sure everything is faulted in.
346      (multiple-value-bind (err? utime stime)      (multiple-value-setq
347                           (mach:unix-getrusage mach:rusage_self)          (old-run-utime old-run-stime old-page-faults old-bytes-consed)
348        (cond ((null err?)        (time-get-sys-info))
349               (error "Unix system call getrusage failed: ~A."      (multiple-value-setq
350                      (mach:get-unix-error-msg utime)))          (new-run-utime new-run-stime new-page-faults new-bytes-consed)
351              (T (setq old-run-utime utime)        (time-get-sys-info))
                (setq old-run-stime stime))))  
     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)  
                          (mach:vm_statistics *task-self*)  
       (declare (ignore ps fc ac ic wc zf ra in ot))  
       (gr-error 'mach:vm_statistics gr)  
       (setq old-page-faults pf))  
     (setq old-bytes-consed (get-bytes-consed))  
   
     (multiple-value-bind (err? utime stime)  
                          (mach:unix-getrusage mach:rusage_self)  
       (cond ((null err?)  
              (error "Unix system call getrusage failed: ~A."  
                     (mach:get-unix-error-msg utime)))  
             (T (setq new-run-utime utime)  
                (setq new-run-stime stime))))  
     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)  
                          (mach:vm_statistics *task-self*)  
       (declare (ignore ps fc ac ic wc zf ra in ot))  
       (gr-error 'mach:vm_statistics gr)  
       (setq new-page-faults pf))  
     (setq new-bytes-consed (get-bytes-consed))  
   
352      (setq run-utime-overhead (- new-run-utime old-run-utime))      (setq run-utime-overhead (- new-run-utime old-run-utime))
353      (setq run-stime-overhead (- new-run-stime old-run-stime))      (setq run-stime-overhead (- new-run-stime old-run-stime))
354      (setq page-faults-overhead (- new-page-faults old-page-faults))      (setq page-faults-overhead (- new-page-faults old-page-faults))
# Line 322  Line 358 
358      (setq real-time-overhead (- new-real-time old-real-time))      (setq real-time-overhead (- new-real-time old-real-time))
359      (setq cons-overhead (- new-bytes-consed old-bytes-consed))      (setq cons-overhead (- new-bytes-consed old-bytes-consed))
360      ;; Now get the initial times.      ;; Now get the initial times.
     (multiple-value-bind (err? utime stime)  
                          (mach:unix-getrusage mach:rusage_self)  
       (cond ((null err?)  
              (error "Unix system call getrusage failed: ~A."  
                     (mach:get-unix-error-msg utime)))  
             (T (setq old-run-utime utime)  
                (setq old-run-stime stime))))  
     (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)  
                          (mach:vm_statistics *task-self*)  
       (declare (ignore ps fc ac ic wc zf ra in ot))  
       (gr-error 'mach:vm_statistics gr)  
       (setq old-page-faults pf))  
361      (setq old-real-time (get-internal-real-time))      (setq old-real-time (get-internal-real-time))
362      (setq old-bytes-consed (get-bytes-consed))      (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      (multiple-value-prog1
368          ;; Execute the form and return its values.          ;; Execute the form and return its values.
369          (funcall fun)          (funcall fun)
370        (multiple-value-bind (err? utime stime)        (incf cycle-count (cycle-count/float))
371                             (mach:unix-getrusage mach:rusage_self)        (multiple-value-setq
372          (cond ((null err?)            (new-run-utime new-run-stime new-page-faults new-bytes-consed)
373                 (error "Unix system call getrusage failed: ~A."          (time-get-sys-info))
                       (mach:get-unix-error-msg utime)))  
               (T (setq new-run-utime (- utime run-utime-overhead))  
                  (setq new-run-stime (- stime run-stime-overhead)))))  
       (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)  
                            (mach:vm_statistics *task-self*)  
         (declare (ignore ps fc ac ic wc zf ra in ot))  
         (gr-error 'mach:vm_statistics gr)  
         (setq new-page-faults (- pf page-faults-overhead)))  
374        (setq new-real-time (- (get-internal-real-time) real-time-overhead))        (setq new-real-time (- (get-internal-real-time) real-time-overhead))
375        (setq new-bytes-consed (- (get-bytes-consed) cons-overhead))        (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))
376        (format *trace-output*              (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead)))
377                "~&Evaluation took:~%  ~          (unless *in-get-time-consing*
378                ~S second~:P of real time~%  ~            (terpri *trace-output*)
379                ~S second~:P of user run time~%  ~            (pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
380                ~S second~:P of system run time~%  ~              (format *trace-output*
381                ~S page fault~:P and~%  ~                      (intl:gettext "Evaluation took:~%  ~
382                ~S bytes consed.~%"                       ~S seconds of real time~%  ~
383                (max (/ (- new-real-time old-real-time)                       ~S seconds of user run time~%  ~
384                        (float internal-time-units-per-second))                       ~S seconds of system run time~%  ")
385                     0.0)                      (max (/ (- new-real-time old-real-time)
386                (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)                              (float internal-time-units-per-second))
387                (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)                           0.0)
388                (max (- new-page-faults old-page-faults) 0)                      (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
389                (max (- new-bytes-consed old-bytes-consed) 0)))))                      (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                        (truncate cycle-count)
398                        "CPU"
399                        (unless (zerop gc-run-time)
400                          (/ (float gc-run-time)
401                             (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                        (max (- bytes-consed (or *time-consing* 0)) 0)))
412              (terpri *trace-output*))
413            (setq *last-time-consing* bytes-consed))))))

Legend:
Removed from v.1.3.1.3  
changed lines
  Added in v.1.33

  ViewVC Help
Powered by ViewVC 1.1.5