Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
5656 commits behind the upstream repository.
  • emarsden's avatar
    fe40afd6
    Add support for hardware cycle counters for Pentium and UltraSPARC. This · fe40afd6
    emarsden authored
    uses the CPUID + RDTSC instructions on Pentium, and reads the %TICK register
    on UltraSPARC. Accessible via the VM::READ-CYCLE-COUNTER VOP that returns
    two (unsigned-byte 32) values, that are the lower and upper components of a
    64-bit cycle count (actually 63 bits for UltraSPARC). Basic support for
    counting the number of CPU cycles has been added to the TIME macro.
    fe40afd6
    History
    Add support for hardware cycle counters for Pentium and UltraSPARC. This
    emarsden authored
    uses the CPUID + RDTSC instructions on Pentium, and reads the %TICK register
    on UltraSPARC. Accessible via the VM::READ-CYCLE-COUNTER VOP that returns
    two (unsigned-byte 32) values, that are the lower and upper components of a
    64-bit cycle count (actually 63 bits for UltraSPARC). Basic support for
    counting the number of CPU cycles has been added to the TIME macro.
time.lisp 12.72 KiB
;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.22 2003/02/25 15:54:54 emarsden Exp $")
;;;
;;; **********************************************************************
;;;
;;;    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.")

(defconstant micro-seconds-per-internal-time-unit
  (/ 1000000 internal-time-units-per-second))




;;; The base number of seconds for our internal "epoch".  We initialize this to
;;; the time of the first call to G-I-R-T, and then subtract this out of the
;;; result.
;;;
(defvar *internal-real-time-base-seconds* nil)
(declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))

;;; 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."
  (locally (declare (optimize (speed 3) (safety 0)))
    (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
      (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
      (let ((base *internal-real-time-base-seconds*)
	    (uint (truncate useconds
			    micro-seconds-per-internal-time-unit)))
	(declare (type (unsigned-byte 32) uint))
	(cond (base
	       (truly-the (unsigned-byte 32)
		    (+ (the (unsigned-byte 32)
			    (* (the (unsigned-byte 32) (- seconds base))
			       internal-time-units-per-second))
		       uint)))
	      (t
	       (setq *internal-real-time-base-seconds* seconds)
	       uint))))))


;;; Get-Internal-Run-Time  --  Public
;;;
#-(and sparc svr4)
(defun get-internal-run-time ()
  "Return the run time in the internal time format.  This is useful for
  finding CPU usage."
  (declare (values (unsigned-byte 32)))
  (locally (declare (optimize (speed 3) (safety 0)))
    (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
			 (unix:unix-fast-getrusage unix:rusage_self)
      (declare (ignore ignore)
	       (type (unsigned-byte 31) utime-sec stime-sec)
	       (type (mod 1000000) utime-usec stime-usec))
      (+ (the (unsigned-byte 32)
	      (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
		 internal-time-units-per-second))
	 (truncate (+ utime-usec stime-usec)
		   micro-seconds-per-internal-time-unit)))))

;;; Get-Internal-Run-Time  --  Public
;;;
#+(and sparc svr4)
(defun get-internal-run-time ()
  "Return the run time in the internal time format.  This is useful for
  finding CPU usage."
  (declare (values (unsigned-byte 32)))
  (locally (declare (optimize (speed 3) (safety 0)))
    (multiple-value-bind (ignore utime stime cutime cstime)
	(unix:unix-times)
      (declare (ignore ignore cutime cstime)
	       (type (unsigned-byte 31) utime stime))
      (the (unsigned-byte 32) (+ utime stime)))))


;;;; Encode and Decode universal times.

;;; CURRENT-TIMEZONE -- internal.
;;;
;;; Returns two values:
;;;  - the minuteswest of GMT.
;;;  - T if daylight savings is in effect, NIL if not.
;;;
(alien:def-alien-routine get-timezone c-call:void
  (when c-call:long :in)
  (minutes-west c-call:int :out)
  (daylight-savings-p alien:boolean :out))


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


;;; 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) (unix:unix-gettimeofday)
    (declare (ignore res))
    (+ secs unix-to-universal-time)))

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


(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.
   Completely ignores daylight-savings-time when time-zone is supplied."
  (multiple-value-bind (daylight timezone)
      (if time-zone
	  (values nil (* time-zone 60 60))
	  (multiple-value-bind
		(ignore minwest dst)
	      (get-timezone (- universal-time unix-to-universal-time))
	    (declare (ignore ignore))
	    (values dst (* minwest 60))))
    (declare (fixnum timezone))
    (multiple-value-bind (weeks secs)
	(truncate (+ (- universal-time timezone) seconds-offset)
		  seconds-in-week)
      (let ((weeks (+ weeks weeks-offset)))
	(multiple-value-bind (t1 second)
	    (truncate secs 60)
	  (let ((tday (truncate t1 minutes-per-day)))
	    (multiple-value-bind (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))
		(let* ((year (+ (* tcent 100)
				(truncate t2 quarter-days-per-year)))
		       (days-since-mar0
			(1+ (truncate (mod t2 quarter-days-per-year) 4)))
		       (day (mod (+ tday weekday-november-17-1858) 7))
		       (t3 (+ (* days-since-mar0 5) 456)))
		  (cond ((>= t3 1989)
			 (setq t3 (- t3 1836))
			 (setq year (1+ year))))
		  (multiple-value-bind (month t3)
		      (truncate t3 153)
		    (let ((date (1+ (truncate t3 5))))
		      (values second minute hour date month year day
			      daylight
			      (if daylight
				  (1+ (/ timezone 60 60))
				  (/ timezone 60 60))))))))))))))


(defun pick-obvious-year (year)
  (declare (type (mod 100) year))
  (let* ((current-year (nth-value 5 (get-decoded-time)))
	 (guess (+ year (* (truncate (- current-year 50) 100) 100))))
    (declare (type (integer 1900 9999) current-year guess))
    (if (> (- current-year guess) 50)
	(+ guess 100)
	guess)))

(defun leap-years-before (year)
  (let ((years (- year 1901)))
    (+ (- (truncate years 4)
	  (truncate years 100))
       (truncate (+ years 300) 400))))

(defvar *days-before-month*
  (collect ((results))
    (results nil)
    (let ((sum 0))
      (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
	(results sum)
	(incf sum days-per-month)))
    (coerce (results) 'vector)))

;;; Encode-Universal-Time  --  Public
;;;
(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."
  (declare (type (mod 60) second)
	   (type (mod 60) minute)
	   (type (mod 24) hour)
	   (type (integer 1 31) date)
	   (type (integer 1 12) month)
	   (type (or (integer 0 99) (integer 1900)) year)
	   (type (or null rational) time-zone))
  (let* ((year (if (< year 100)
		   (pick-obvious-year year)
		   year))
	 (days (+ (1- date)
		  (aref *days-before-month* month)
		  (if (> month 2)
		      (leap-years-before (1+ year))
		      (leap-years-before year))
		  (* (- year 1900) 365)))
	 (hours (+ hour (* days 24))))
    (if time-zone
	(+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
	(let* ((minwest-guess
		(nth-value 1
			   (get-timezone (- (* hours 60 60)
					    unix-to-universal-time))))
	       (guess (+ minute (* hours 60) minwest-guess))
	       (minwest
		(nth-value 1
			   (get-timezone (- (* guess 60)
					    unix-to-universal-time)))))
	  (+ second (* (+ guess (- minwest minwest-guess)) 60))))))


;;;; Time:

(defmacro time (form)
  "Evaluates the Form and prints timing information on *Trace-Output*."
  `(%time #'(lambda () ,form)))

;;; MASSAGE-TIME-FUNCTION  --  Internal
;;;
;;;    Try to compile the closure arg to %TIME if it is interpreted.
;;;
(defun massage-time-function (fun)
  (cond
   ((eval:interpreted-function-p fun)
    (multiple-value-bind (def env-p)
			 (function-lambda-expression fun)
      (declare (ignore def))
      (cond
       (env-p
	(warn "TIME form in a non-null environment, forced to interpret.~@
	       Compiling entire form will produce more accurate times.")
	fun)
       (t
	(compile nil fun)))))
   (t fun)))

;;; TIME-GET-SYS-INFO  --  Internal
;;;
;;;    Return all the values that we want time to report.
;;;
(defun time-get-sys-info ()
  (multiple-value-bind (user sys faults)
		       (system:get-system-info)
    (values user sys faults (get-bytes-consed))))

#+(or pentium sparc-v9)
(defun cycle-count/float ()
  (multiple-value-bind (lo hi)
      (vm::read-cycle-counter)
    (+ (* hi (expt 2.0d0 32)) lo)))

#-(or pentium sparc-v9)
(defun cycle-count/float () 0.0)


;;; %TIME  --  Internal
;;;
;;;    The guts of the TIME macro.  Compute overheads, run the (compiled)
;;; function, report the times.
;;;
(defun %time (fun)
  (let ((fun (massage-time-function fun))
	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
        cycle-count
        page-faults-overhead
        old-bytes-consed
        new-bytes-consed
        cons-overhead)
    ;; Calculate the overhead...
    (multiple-value-setq
        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
      (time-get-sys-info))
    ;; Do it a second time to make sure everything is faulted in.
    (multiple-value-setq
        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
      (time-get-sys-info))
    (multiple-value-setq
        (new-run-utime new-run-stime new-page-faults new-bytes-consed)
      (time-get-sys-info))
    (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.
    (setq old-real-time (get-internal-real-time))
    (multiple-value-setq
        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
      (time-get-sys-info))
    (let ((start-gc-run-time *gc-run-time*))
    (setq cycle-count (- (cycle-count/float)))
    (multiple-value-prog1
        ;; Execute the form and return its values.
        (funcall fun)
      (incf cycle-count (cycle-count/float))
      (multiple-value-setq
	  (new-run-utime new-run-stime new-page-faults new-bytes-consed)
	(time-get-sys-info))
      (setq new-real-time (- (get-internal-real-time) real-time-overhead))
      (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
	(terpri *trace-output*)
	(pprint-logical-block (*trace-output* nil :per-line-prefix "; ")
	  (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~%  ~
                 ~D CPU cycles~%  ~
		 ~@[[Run times include ~S second~:P GC run time]~%  ~]~
		 ~S page fault~:P and~%  ~
		 ~:D 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)
                  (truncate cycle-count)
		  (unless (zerop gc-run-time)
		    (/ (float gc-run-time)
		       (float internal-time-units-per-second)))
		  (max (- new-page-faults old-page-faults) 0)
		  (max (- new-bytes-consed old-bytes-consed cons-overhead)
		       0))))
	(terpri *trace-output*)))))