0.9.2.43:
[sbcl.git] / src / code / time.lisp
index c028cb2..52c3059 100644 (file)
   (multiple-value-bind (ignore seconds useconds) (sb!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)))
+          (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))
-                                  sb!xc:internal-time-units-per-second))
-                          uint)))
-           (t
-            (setq *internal-real-time-base-seconds* seconds)
-            uint)))))
+             (truly-the (unsigned-byte 32)
+                        (+ (the (unsigned-byte 32)
+                                (* (the (unsigned-byte 32) (- seconds base))
+                                   sb!xc:internal-time-units-per-second))
+                           uint)))
+            (t
+             (setq *internal-real-time-base-seconds* seconds)
+             uint)))))
 
 (defun get-internal-run-time ()
   #!+sb-doc
   (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
       (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
     (declare (ignore ignore)
-            (type (unsigned-byte 31) utime-sec stime-sec)
-            ;; (Classic CMU CL had these (MOD 1000000) instead, but
-            ;; at least in Linux 2.2.12, the type doesn't seem to be
-            ;; documented anywhere and the observed behavior is to
-            ;; sometimes return 1000000 exactly.)
-            (type (integer 0 1000000) utime-usec stime-usec))
+             (type (unsigned-byte 31) utime-sec stime-sec)
+             ;; (Classic CMU CL had these (MOD 1000000) instead, but
+             ;; at least in Linux 2.2.12, the type doesn't seem to be
+             ;; documented anywhere and the observed behavior is to
+             ;; sometimes return 1000000 exactly.)
+             (type (integer 0 1000000) utime-usec stime-usec))
     (let ((result (+ (the (unsigned-byte 32)
-                         (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
-                            sb!xc:internal-time-units-per-second))
-                    (floor (+ utime-usec
-                              stime-usec
-                              (floor micro-seconds-per-internal-time-unit 2))
-                           micro-seconds-per-internal-time-unit))))
+                          (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
+                             sb!xc:internal-time-units-per-second))
+                     (floor (+ utime-usec
+                               stime-usec
+                               (floor micro-seconds-per-internal-time-unit 2))
+                            micro-seconds-per-internal-time-unit))))
       result)))
 \f
 ;;;; Encode and decode universal times.
 (defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0))
 
 (defun years-since-mar-2000 (utime)
-  "Returns number of complete years since March 1st 2000, and remainder in seconds" 
+  "Returns number of complete years since March 1st 2000, and remainder in seconds"
   (let* ((days-in-year (* 86400 365))
-        (days-in-4year (+ (* 4 days-in-year) 86400))
-        (days-in-100year (- (* 25 days-in-4year) 86400))
-        (days-in-400year (+ (* 4 days-in-100year) 86400))
-        (offset (- utime +mar-1-2000+))
-        (year 0))
+         (days-in-4year (+ (* 4 days-in-year) 86400))
+         (days-in-100year (- (* 25 days-in-4year) 86400))
+         (days-in-400year (+ (* 4 days-in-100year) 86400))
+         (offset (- utime +mar-1-2000+))
+         (year 0))
     (labels ((whole-num (x y inc max)
-              (let ((w (truncate x y)))
-                (when (and max (> w max)) (setf w max))
-                (incf year (* w inc))
-                (* w y))))
+               (let ((w (truncate x y)))
+                 (when (and max (> w max)) (setf w max))
+                 (incf year (* w inc))
+                 (* w y))))
       (decf offset (whole-num offset days-in-400year 400 nil))
       (decf offset (whole-num offset days-in-100year 100 3))
       (decf offset (whole-num offset days-in-4year 4 25))
 (defun truncate-to-unix-range (utime)
   (let ((unix-time (- utime unix-to-universal-time)))
     (if (< unix-time (ash 1 31))
-       unix-time
-       (multiple-value-bind (year offset) (years-since-mar-2000 utime)
-         (declare (ignore year))
-         (+  +mar-1-2035+  (- unix-to-universal-time)  offset)))))
-  
+        unix-time
+        (multiple-value-bind (year offset) (years-since-mar-2000 utime)
+          (declare (ignore year))
+          (+  +mar-1-2035+  (- unix-to-universal-time)  offset)))))
+
 (defun decode-universal-time (universal-time &optional time-zone)
   #!+sb-doc
   "Converts a universal-time to decoded time format returning the following
    Completely ignores daylight-savings-time when time-zone is supplied."
   (multiple-value-bind (daylight seconds-west)
       (if time-zone
-         (values nil (* time-zone 60 60))
-         (multiple-value-bind (ignore seconds-west daylight)
-             (sb!unix::get-timezone (truncate-to-unix-range universal-time))
-           (declare (ignore ignore))
-           (declare (fixnum seconds-west))
-           (values daylight seconds-west)))
+          (values nil (* time-zone 60 60))
+          (multiple-value-bind (ignore seconds-west daylight)
+              (sb!unix::get-timezone (truncate-to-unix-range universal-time))
+            (declare (ignore ignore))
+            (declare (fixnum seconds-west))
+            (values daylight seconds-west)))
     (declare (fixnum seconds-west))
     (multiple-value-bind (weeks secs)
-       (truncate (+ (- universal-time seconds-west) seconds-offset)
-                 seconds-in-week)
+        (truncate (+ (- universal-time seconds-west) 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+ (/ seconds-west 60 60))
-                                 (/ seconds-west 60 60))))))))))))))
+        (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+ (/ seconds-west 60 60))
+                                  (/ seconds-west 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))))
+         (guess (+ year (* (truncate (- current-year 50) 100) 100))))
     (declare (type (integer 1900 9999) current-year guess))
     (if (> (- current-year guess) 50)
-       (+ guess 100)
-       guess)))
+        (+ guess 100)
+        guess)))
 
 (defun leap-years-before (year)
   (let ((years (- year 1901)))
     (+ (- (truncate years 4)
-         (truncate years 100))
+          (truncate years 100))
        (truncate (+ years 300) 400))))
 
 (defvar *days-before-month*
   #.(let ((reversed-result nil)
-         (sum 0))
+          (sum 0))
       (push nil reversed-result)
       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
-       (push sum reversed-result)
-       (incf sum days-in-month))
+        (push sum reversed-result)
+        (incf sum days-in-month))
       (coerce (nreverse reversed-result) 'simple-vector)))
 
-           
+
 (defun encode-universal-time (second minute hour date month year
-                                    &optional time-zone)
+                                     &optional time-zone)
   #!+sb-doc
   "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))
+           (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))))
+                   (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))
-       ;; can't ask unix for times after 2037: this is only a problem
-       ;; if we need to query the system timezone
-       (if (> year 2037)
-           (labels ((leap-year-p (year)
-                      (cond ((zerop (mod year 400)) t)
-                            ((zerop (mod year 100)) nil)
-                            ((zerop (mod year 4)) t)
-                            (t nil))))
-             (let* ((fake-year (if (leap-year-p year) 2036 2037))
-                    (fake-time (encode-universal-time second minute hour
-                                                      date month fake-year)))
-               (+ fake-time
-                  (* 86400 (+ (* 365 (- year fake-year))
-                              (- (leap-years-before year)
-                                 (leap-years-before fake-year)))))))
-           (let* ((secwest-guess
-                   (sb!unix::unix-get-seconds-west
-                    (- (* hours 60 60) unix-to-universal-time)))
-                  (guess (+ second (* 60 (+ minute (* hours 60)))
-                            secwest-guess))
-                  (secwest
-                   (sb!unix::unix-get-seconds-west
-                    (- guess unix-to-universal-time))))
-             (+ guess (- secwest secwest-guess)))))))
+        (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
+        ;; can't ask unix for times after 2037: this is only a problem
+        ;; if we need to query the system timezone
+        (if (> year 2037)
+            (labels ((leap-year-p (year)
+                       (cond ((zerop (mod year 400)) t)
+                             ((zerop (mod year 100)) nil)
+                             ((zerop (mod year 4)) t)
+                             (t nil))))
+              (let* ((fake-year (if (leap-year-p year) 2036 2037))
+                     (fake-time (encode-universal-time second minute hour
+                                                       date month fake-year)))
+                (+ fake-time
+                   (* 86400 (+ (* 365 (- year fake-year))
+                               (- (leap-years-before year)
+                                  (leap-years-before fake-year)))))))
+            (let* ((secwest-guess
+                    (sb!unix::unix-get-seconds-west
+                     (- (* hours 60 60) unix-to-universal-time)))
+                   (guess (+ second (* 60 (+ minute (* hours 60)))
+                             secwest-guess))
+                   (secwest
+                    (sb!unix::unix-get-seconds-west
+                     (- guess unix-to-universal-time))))
+              (+ guess (- secwest secwest-guess)))))))
 \f
 ;;;; TIME
 
 (defun %time (fun)
   (declare (type function fun))
   (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)
+        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-setq
-       (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+        (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)
+        (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)
+        (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 cons-overhead (- new-bytes-consed old-bytes-consed))
     ;; Now get the initial times.
     (multiple-value-setq
-       (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
       (time-get-sys-info))
     (setq old-real-time (get-internal-real-time))
     (let ((start-gc-run-time *gc-run-time*))
     (multiple-value-prog1
-       ;; Execute the form and return its values.
-       (funcall fun)
+        ;; Execute the form and return its values.
+        (funcall fun)
       (multiple-value-setq
-         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
-       (time-get-sys-info))
+          (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)))
-       (format *trace-output*
-               "~&Evaluation took:~%  ~
+        (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~%  ~
 ~@[                 [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 sb!xc: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)
-               (unless (zerop gc-run-time)
-                 (/ (float gc-run-time)
-                    (float sb!xc:internal-time-units-per-second)))
-               (max (- new-page-faults old-page-faults) 0)
-               (max (- new-bytes-consed old-bytes-consed) 0)))))))
+                (max (/ (- new-real-time old-real-time)
+                        (float sb!xc: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)
+                (unless (zerop gc-run-time)
+                  (/ (float gc-run-time)
+                     (float sb!xc:internal-time-units-per-second)))
+                (max (- new-page-faults old-page-faults) 0)
+                (max (- new-bytes-consed old-bytes-consed) 0)))))))