Skip to content
Snippets Groups Projects
time.lisp 14.3 KiB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404
;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains the definitions for the Spice Lisp time functions.
;;; They are mostly fairly straightforwardly implemented as calls to the 
;;; time server.
;;;
;;;    Written by Rob MacLachlan.
;;;
(in-package 'lisp)
(export '(internal-time-units-per-second get-internal-real-time
	  get-internal-run-time get-universal-time
	  get-decoded-time encode-universal-time decode-universal-time))

(defconstant internal-time-units-per-second 100
  "The number of internal time units that fit into a second.  See
  Get-Internal-Real-Time and Get-Internal-Run-Time.")

(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)))))

;;; Get-Internal-Real-Time  --  Public
;;;
;;;
(defun get-internal-real-time ()
  "Return the real time in the internal time format.  This is useful for
  finding elapsed time.  See Internal-Time-Units-Per-Second."
  (let ((val (system:%primitive get-real-time)))
    (when (eq val -1)
      (error "Failed to get real time."))
    val))

#|
(defun get-internal-real-time ()
  "Return the real time in the internal time format.  This is useful for
  finding elapsed time.  See Internal-Time-Units-Per-Second."
  (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)
    (if result (+ (* seconds internal-time-units-per-second) useconds)
	(error "Unix system call gettimeofday failed: ~A"
	       (mach:get-unix-error-msg seconds)))))
|#

;;; Get-Internal-Run-Time  --  Public
;;;
;;; PmGetTimes returns run time in microseconds.  Convert to jiffies.
;;;
(defun get-internal-run-time ()
  "Return the run time in the internal time format.  This is useful for
  finding CPU usage."
  (let ((val (system:%primitive get-run-time)))
    (when (eq val -1)
      (error "Failed to obtain run time."))
    val))

#|
(defun get-internal-run-time ()
  "Return the run time in the internal time format.  This is useful for
  finding CPU usage."
  (multiple-value-bind (result utime stime)
		       (mach:unix-getrusage mach:rusage_self)
    (if result (+ utime stime)
	(error "Unix system call getrusage failed: ~A"
	       (mach:get-unix-error-msg utime)))))
|#

;;; Subtract from the returned Internal_Time to get the universal time.
;;; The offset between our time base and the Perq one is 2145 weeks and
;;; five days.
;;;
(defconstant seconds-in-week (* 60 60 24 7))
(defconstant weeks-offset 2145)
(defconstant seconds-offset 432000)
(defconstant minutes-per-day (* 24 60))
(defconstant quarter-days-per-year (1+ (* 365 4)))
(defconstant quarter-days-per-century 146097)
(defconstant november-17-1858 678882)
(defconstant weekday-november-17-1858 2)
(defconstant unix-to-universal-time 2208988800)

;;; 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)))

;;; Get-Universal-Time  --  Public
;;;
;;;
(defun get-universal-time ()
  "Returns a single integer for the current time of
   day in universal time format."
  (multiple-value-bind (res secs) (mach:unix-gettimeofday)
    (declare (ignore res))
    (+ secs unix-to-universal-time)))

;;; Get-Decoded-Time  --  Public
;;;
;;;

(defun get-decoded-time ()
  "Returns nine values specifying the current time as follows:
  second, minute, hour, date, month, year, day of week (0 = Monday),
  T (daylight savings times) or NIL (standard time), and timezone."
  (decode-universal-time (get-universal-time)))

;;; Decode-Universal-Time  --  Public
;;;
;;;

(defun decode-universal-time (universal-time &optional time-zone)
  "Converts a universal-time to decoded time format returning
  the following nine values: second, minute, hour, date, month,
  year, day of week (0 = Monday), T (daylight savings time) or
  NIL (standard time), and timezone."
  (declare (type (or fixnum null) time-zone))
  (multiple-value-bind (weeks secs)
		       (truncate (+ universal-time seconds-offset)
				 seconds-in-week)
    (let ((weeks (+ weeks weeks-offset))
	  (second NIL)
	  (minute NIL)
	  (hour NIL)
	  (date NIL)
	  (month NIL)
	  (year NIL)
	  (day NIL)
	  (daylight NIL)
	  (timezone (if (null time-zone)
			(multiple-value-bind (res s us tz)
					     (mach:unix-gettimeofday)
			  (declare (ignore s us))
			  (if res tz 0))
			(* time-zone 60))))
      (declare (fixnum timezone))
      (multiple-value-bind (t1 seconds) (truncate secs 60)
	(setq second seconds)
	(setq t1 (- t1 timezone))
	(let* ((tday (if (< t1 0)
			 (1- (truncate (1+ t1) minutes-per-day))
			 (truncate t1 minutes-per-day))))
	  (multiple-value-setq (hour minute)
	    (truncate (- t1 (* tday minutes-per-day)) 60))
	  (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
		 (tcent (truncate t2 quarter-days-per-century)))
	    (setq t2 (mod t2 quarter-days-per-century))
	    (setq t2 (+ (- t2 (mod t2 4)) 3))
	    (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
	    (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
						 4))))
	      (setq day (mod (+ tday weekday-november-17-1858) 7))
	      (if (setq daylight (dst-check days-since-mar0 hour day))
		  (cond ((eq hour 23)
			 (setq hour 0)
			 (setq day (mod (1+ day) 7))
			 (setq days-since-mar0 (1+ days-since-mar0))
			 (if (>= days-since-mar0 366)
			     (if (or (> days-since-mar0 366)
				     (not-leap-year (1+ year)))
				 (setq days-since-mar0 368))))
			(T (setq hour (1+ hour)))))
	      (let ((t3 (+ (* days-since-mar0 5) 456)))
		(cond ((>= t3 1989)
		       (setq t3 (- t3 1836))
		       (setq year (1+ year))))
		(multiple-value-setq (month t3) (truncate t3 153))
		(setq date (1+ (truncate t3 5))))))))
      (values second minute hour date month year day
	      daylight (truncate timezone 60)))))

;;; Encode-Universal-Time  --  Public
;;;
;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we 
;;; have to figure out which the "obvious" year is.
;;;

(defun encode-universal-time (second minute hour date month year
				     &optional time-zone)
  "The time values specified in decoded format are converted to 
   universal time, which is returned."
  (let* ((year (if (< year 100)
		   (multiple-value-bind (sec min hour day month now-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)))
		   year))
	 (zone (if time-zone (* time-zone 60)
		   (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)
		     (declare (ignore s us))
		     (if res tz))))
	 (tmonth (- month 3)))
    (cond ((< tmonth 0)
	   (setq tmonth (+ tmonth 12))
	   (setq year (1- year))))
    (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
      (multiple-value-bind (tcent tyear) (truncate year 100)
	(let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
			   (truncate (* tyear quarter-days-per-year) 4)
			   days-since-mar0)
			november-17-1858))
	       (daylight (dst-check days-since-mar0 (1- hour)
				    (mod (+ tday weekday-november-17-1858) 7)))
	       (tminutes (+ (* hour 60) minute zone)))
	  (if daylight (setq tminutes (- tminutes 60)))
	  (do ((i tminutes (+ i minutes-per-day)))
	      ((>= 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))))

(defmacro time (form)
  "Evaluates the Form and prints timing information on *Trace-Output*."
  (let ((old-run-utime (gensym))
	(new-run-utime (gensym))
	(old-run-stime (gensym))
	(new-run-stime (gensym))
	(old-real-time (gensym))
	(new-real-time (gensym))
	(old-page-faults (gensym))
	(new-page-faults (gensym))
	(real-time-overhead (gensym))
	(run-utime-overhead (gensym))
	(run-stime-overhead (gensym))
	(page-faults-overhead (gensym))
	(old-bytes-consed (gensym))
	(new-bytes-consed (gensym))
	(cons-overhead (gensym))
	(err? (gensym))
	(utime (gensym))
	(stime (gensym)))
    `(let (,old-run-utime
	   ,new-run-utime
	   ,old-run-stime
	   ,new-run-stime
	   ,old-real-time
	   ,new-real-time
	   ,old-page-faults
	   ,new-page-faults
	   ,real-time-overhead
	   ,run-utime-overhead
	   ,run-stime-overhead
	   ,page-faults-overhead
	   ,old-bytes-consed
	   ,new-bytes-consed
	   ,cons-overhead)
       ;; Calculate the overhead...
       (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_allocate gr)
	 (setq ,old-page-faults pf))
       (setq ,old-bytes-consed (get-bytes-consed))
       ;; Do it a second time, to make sure everything is faulted in.
       (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))
       (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))

       (setq ,run-utime-overhead (- ,new-run-utime ,old-run-utime))
       (setq ,run-stime-overhead (- ,new-run-stime ,old-run-stime))
       (setq ,page-faults-overhead (- ,new-page-faults ,old-page-faults))
       (setq ,old-real-time (get-internal-real-time))
       (setq ,old-real-time (get-internal-real-time))
       (setq ,new-real-time (get-internal-real-time))
       (setq ,real-time-overhead (- ,new-real-time ,old-real-time))
       (setq ,cons-overhead (- ,new-bytes-consed ,old-bytes-consed))
       ;; 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))
       (setq ,old-real-time (get-internal-real-time))
       (setq ,old-bytes-consed (get-bytes-consed))
       (multiple-value-prog1
	;; Execute the form, and return its values.
	   ,form
	 (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 ,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)))
	 (setq ,new-real-time (- (get-internal-real-time) ,real-time-overhead))
	 (setq ,new-bytes-consed (- (get-bytes-consed) ,cons-overhead))
	 (format *trace-output*
		 "~&Evaluation took:~%  ~
		 ~S second~:P of real time,~%  ~
		 ~S second~:P of user run time,~%  ~
		 ~S second~:P of system run time,~%  ~
		 ~S page fault~:P, and~%  ~
		 ~S bytes consed.~%"
		 (max (/ (- ,new-real-time ,old-real-time)
			 (float internal-time-units-per-second))
		      0.0)
		 (max (/ (- ,new-run-utime ,old-run-utime) 1000000.0) 0.0)
		 (max (/ (- ,new-run-stime ,old-run-stime) 1000000.0) 0.0)
		 (max (- ,new-page-faults ,old-page-faults) 0)
		 (max (- ,new-bytes-consed ,old-bytes-consed) 0))))))