src/code/time.lisp

   1 ;;;; low-level time functions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defconstant internal-time-units-per-second 100
  15   #!+sb-doc
  16   "The number of internal time units that fit into a second. See
  17   GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.")
  18
  19 (defconstant micro-seconds-per-internal-time-unit
  20   (/ 1000000 internal-time-units-per-second))
  21 \f
  22 ;;; The base number of seconds for our internal "epoch". We initialize
  23 ;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and
  24 ;;; then subtract this out of the result.
  25 (defvar *internal-real-time-base-seconds* nil)
  26 (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
  27
  28 (defun get-internal-real-time ()
  29   #!+sb-doc
  30   "Return the real time in the internal time format. This is useful for
  31   finding elapsed time. See INTERNAL-TIME-UNITS-PER-SECOND."
  32   ;; FIXME: See comment on OPTIMIZE declaration in GET-INTERNAL-RUN-TIME.
  33   (declare (optimize (speed 3) (safety 3)))
  34   (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
  35     (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
  36     (let ((base *internal-real-time-base-seconds*)
  37           (uint (truncate useconds
  38                           micro-seconds-per-internal-time-unit)))
  39       (declare (type (unsigned-byte 32) uint))
  40       (cond (base
  41              (truly-the (unsigned-byte 32)
  42                         (+ (the (unsigned-byte 32)
  43                                 (* (the (unsigned-byte 32) (- seconds base))
  44                                    internal-time-units-per-second))
  45                            uint)))
  46             (t
  47              (setq *internal-real-time-base-seconds* seconds)
  48              uint)))))
  49
  50 ;;; REMOVEME once runtime nonmonotonicity problem is debugged
  51 (defvar *last-utime-sec*)
  52 (defvar *last-utime-usec*)
  53 (defvar *last-stime-sec*)
  54 (defvar *last-stime-usec*)
  55 (defvar *last-internal-run-time*)
  56 (push (lambda ()
  57         (makunbound '*last-internal-run-time*))
  58       *before-save-initializations*)
  59
  60 (defun get-internal-run-time ()
  61   #!+sb-doc
  62   "Return the run time in the internal time format. This is useful for
  63   finding CPU usage."
  64   (declare (values (unsigned-byte 32)))
  65   ;; FIXME: In CMU CL this was (SPEED 3) (SAFETY 0), and perhaps
  66   ;; someday it should be again, since overhead here is annoying. But
  67   ;; it's even more annoying to worry about this function returning
  68   ;; out-of-range values, so while debugging the profiling code,
  69   ;; I set it to (SAFETY 3) for now.
  70   (declare (optimize (speed 3) (safety 3)))
  71   (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
  72       (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
  73     (declare (ignore ignore)
  74              (type (unsigned-byte 31) utime-sec stime-sec)
  75              ;; (Classic CMU CL had these (MOD 1000000) instead, but
  76              ;; at least in Linux 2.2.12, the type doesn't seem to be
  77              ;; documented anywhere and the observed behavior is to
  78              ;; sometimes return 1000000 exactly.)
  79              (type (integer 0 1000000) utime-usec stime-usec))
  80
  81     (let ((result (+ (the (unsigned-byte 32)
  82                           (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
  83                              internal-time-units-per-second))
  84                      (floor (+ utime-usec
  85                                stime-usec
  86                                (floor micro-seconds-per-internal-time-unit 2))
  87                             micro-seconds-per-internal-time-unit))))
  88
  89       ;; REMOVEME once runtime nonmonotonicity problem is debugged
  90       (when (boundp '*last-internal-run-time*)
  91         (unless (>= result *last-internal-run-time*)
  92           (error "non-monotonic:~@
  93                   UTIME-SEC ~S ~S~@
  94                   UTIME-USEC ~S ~S~@
  95                   STIME-SEC ~S ~S~@
  96                   STIME-USEC ~S ~S~@
  97                   RESULT ~S ~S"
  98                  *last-utime-sec* utime-sec
  99                  *last-utime-usec* utime-usec
 100                  *last-stime-sec* stime-sec
 101                  *last-stime-usec* stime-usec
 102                  *last-internal-run-time* result)))
 103       (setf *last-utime-sec* utime-sec
 104             *last-utime-usec* utime-usec
 105             *last-stime-sec* stime-sec
 106             *last-stime-usec* stime-usec
 107             *last-internal-run-time* result)
 108
 109       result)))
 110 \f
 111 ;;;; Encode and decode universal times.
 112
 113 ;;; Returns two values:
 114 ;;;  - the minutes west of GMT.
 115 ;;;  - T if daylight savings is in effect, NIL if not.
 116 (sb!alien:def-alien-routine get-timezone sb!c-call:void
 117   (when sb!c-call:long :in)
 118   (minutes-west sb!c-call:int :out)
 119   (daylight-savings-p sb!alien:boolean :out))
 120
 121 ;;; Subtract from the returned Internal-Time to get the universal
 122 ;;; time. The offset between our time base and the Perq one is 2145
 123 ;;; weeks and five days.
 124 (defconstant seconds-in-week (* 60 60 24 7))
 125 (defconstant weeks-offset 2145)
 126 (defconstant seconds-offset 432000)
 127 (defconstant minutes-per-day (* 24 60))
 128 (defconstant quarter-days-per-year (1+ (* 365 4)))
 129 (defconstant quarter-days-per-century 146097)
 130 (defconstant november-17-1858 678882)
 131 (defconstant weekday-november-17-1858 2)
 132 (defconstant unix-to-universal-time 2208988800)
 133
 134 (defun get-universal-time ()
 135   #!+sb-doc
 136   "Returns a single integer for the current time of
 137    day in universal time format."
 138   (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
 139     (declare (ignore res))
 140     (+ secs unix-to-universal-time)))
 141
 142 (defun get-decoded-time ()
 143   #!+sb-doc
 144   "Returns nine values specifying the current time as follows:
 145    second, minute, hour, date, month, year, day of week (0 = Monday), T
 146    (daylight savings times) or NIL (standard time), and timezone."
 147   (decode-universal-time (get-universal-time)))
 148
 149 (defun decode-universal-time (universal-time &optional time-zone)
 150   #!+sb-doc
 151   "Converts a universal-time to decoded time format returning the following
 152    nine values: second, minute, hour, date, month, year, day of week (0 =
 153    Monday), T (daylight savings time) or NIL (standard time), and timezone.
 154    Completely ignores daylight-savings-time when time-zone is supplied."
 155   (multiple-value-bind (weeks secs)
 156       (truncate (+ universal-time seconds-offset)
 157                 seconds-in-week)
 158     (let* ((weeks (+ weeks weeks-offset))
 159            (second NIL)
 160            (minute NIL)
 161            (hour NIL)
 162            (date NIL)
 163            (month NIL)
 164            (year NIL)
 165            (day NIL)
 166            (daylight NIL)
 167            (timezone (if (null time-zone)
 168                          (multiple-value-bind
 169                              (ignore minwest dst)
 170                              (get-timezone (- universal-time
 171                                               unix-to-universal-time))
 172                            (declare (ignore ignore))
 173                            (setf daylight dst)
 174                            minwest)
 175                          (* time-zone 60))))
 176       (declare (fixnum timezone))
 177       (multiple-value-bind (t1 seconds) (truncate secs 60)
 178         (setq second seconds)
 179         (setq t1 (- t1 timezone))
 180         (let* ((tday (if (< t1 0)
 181                          (1- (truncate (1+ t1) minutes-per-day))
 182                          (truncate t1 minutes-per-day))))
 183           (multiple-value-setq (hour minute)
 184             (truncate (- t1 (* tday minutes-per-day)) 60))
 185           (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
 186                  (tcent (truncate t2 quarter-days-per-century)))
 187             (setq t2 (mod t2 quarter-days-per-century))
 188             (setq t2 (+ (- t2 (mod t2 4)) 3))
 189             (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
 190             (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
 191                                                  4))))
 192               (setq day (mod (+ tday weekday-november-17-1858) 7))
 193               (let ((t3 (+ (* days-since-mar0 5) 456)))
 194                 (cond ((>= t3 1989)
 195                        (setq t3 (- t3 1836))
 196                        (setq year (1+ year))))
 197                 (multiple-value-setq (month t3) (truncate t3 153))
 198                 (setq date (1+ (truncate t3 5))))))))
 199       (values second minute hour date month year day
 200               daylight
 201               (if daylight
 202                   (1+ (/ timezone 60))
 203                   (/ timezone 60))))))
 204
 205 (defun pick-obvious-year (year)
 206   (declare (type (mod 100) year))
 207   (let* ((current-year (nth-value 5 (get-decoded-time)))
 208          (guess (+ year (* (truncate (- current-year 50) 100) 100))))
 209     (declare (type (integer 1900 9999) current-year guess))
 210     (if (> (- current-year guess) 50)
 211         (+ guess 100)
 212         guess)))
 213
 214 (defun leap-years-before (year)
 215   (let ((years (- year 1901)))
 216     (+ (- (truncate years 4)
 217           (truncate years 100))
 218        (truncate (+ years 300) 400))))
 219
 220 (defvar *days-before-month*
 221   #.(let ((reversed-result nil)
 222           (sum 0))
 223       (push nil reversed-result)
 224       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
 225         (push sum reversed-result)
 226         (incf sum days-in-month))
 227       (coerce (nreverse reversed-result) 'simple-vector)))
 228
 229 (defun encode-universal-time (second minute hour date month year
 230                                      &optional time-zone)
 231   #!+sb-doc
 232   "The time values specified in decoded format are converted to
 233    universal time, which is returned."
 234   (declare (type (mod 60) second)
 235            (type (mod 60) minute)
 236            (type (mod 24) hour)
 237            (type (integer 1 31) date)
 238            (type (integer 1 12) month)
 239            (type (or (integer 0 99) (integer 1900)) year)
 240            (type (or null rational) time-zone))
 241   (let* ((year (if (< year 100)
 242                    (pick-obvious-year year)
 243                    year))
 244          (days (+ (1- date)
 245                   (aref *days-before-month* month)
 246                   (if (> month 2)
 247                       (leap-years-before (1+ year))
 248                       (leap-years-before year))
 249                   (* (- year 1900) 365)))
 250          (hours (+ hour (* days 24))))
 251     (if time-zone
 252         (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
 253         (let* ((minwest-guess
 254                 (nth-value 1
 255                            (get-timezone (- (* hours 60 60)
 256                                             unix-to-universal-time))))
 257                (guess (+ minute (* hours 60) minwest-guess))
 258                (minwest
 259                 (nth-value 1
 260                            (get-timezone (- (* guess 60)
 261                                             unix-to-universal-time)))))
 262           (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
 263 \f
 264 ;;;; TIME
 265
 266 (defmacro time (form)
 267   #!+sb-doc
 268   "Evaluates the Form and prints timing information on *Trace-Output*."
 269   `(%time #'(lambda () ,form)))
 270
 271 ;;; Try to compile the closure arg to %TIME if it is interpreted.
 272 (defun massage-time-function (fun)
 273   (cond
 274    ((sb!eval:interpreted-function-p fun)
 275     (multiple-value-bind (def env-p) (function-lambda-expression fun)
 276       (declare (ignore def))
 277       (cond
 278        (env-p
 279         (warn "TIME form in a non-null environment, forced to interpret.~@
 280                Compiling entire form will produce more accurate times.")
 281         fun)
 282        (t
 283         (compile nil fun)))))
 284    (t fun)))
 285
 286 ;;; Return all the files that we want time to report.
 287 (defun time-get-sys-info ()
 288   (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
 289     (values user sys faults (get-bytes-consed))))
 290
 291 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
 292 ;;; function, report the times.
 293 (defun %time (fun)
 294   (let ((fun (massage-time-function fun))
 295         old-run-utime
 296         new-run-utime
 297         old-run-stime
 298         new-run-stime
 299         old-real-time
 300         new-real-time
 301         old-page-faults
 302         new-page-faults
 303         real-time-overhead
 304         run-utime-overhead
 305         run-stime-overhead
 306         page-faults-overhead
 307         old-bytes-consed
 308         new-bytes-consed
 309         cons-overhead)
 310     ;; Calculate the overhead...
 311     (multiple-value-setq
 312         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 313       (time-get-sys-info))
 314     ;; Do it a second time to make sure everything is faulted in.
 315     (multiple-value-setq
 316         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 317       (time-get-sys-info))
 318     (multiple-value-setq
 319         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 320       (time-get-sys-info))
 321     (setq run-utime-overhead (- new-run-utime old-run-utime))
 322     (setq run-stime-overhead (- new-run-stime old-run-stime))
 323     (setq page-faults-overhead (- new-page-faults old-page-faults))
 324     (setq old-real-time (get-internal-real-time))
 325     (setq old-real-time (get-internal-real-time))
 326     (setq new-real-time (get-internal-real-time))
 327     (setq real-time-overhead (- new-real-time old-real-time))
 328     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
 329     ;; Now get the initial times.
 330     (multiple-value-setq
 331         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 332       (time-get-sys-info))
 333     (setq old-real-time (get-internal-real-time))
 334     (let ((start-gc-run-time *gc-run-time*))
 335     (multiple-value-prog1
 336         ;; Execute the form and return its values.
 337         (funcall fun)
 338       (multiple-value-setq
 339           (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 340         (time-get-sys-info))
 341       (setq new-real-time (- (get-internal-real-time) real-time-overhead))
 342       (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
 343         (format *trace-output*
 344                 "~&Evaluation took:~%  ~
 345                  ~S second~:P of real time~%  ~
 346                  ~S second~:P of user run time~%  ~
 347                  ~S second~:P of system run time~%  ~
 348 ~@[                 [Run times include ~S second~:P GC run time.]~%  ~]~
 349                  ~S page fault~:P and~%  ~
 350                  ~S bytes consed.~%"
 351                 (max (/ (- new-real-time old-real-time)
 352                         (float internal-time-units-per-second))
 353                      0.0)
 354                 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
 355                 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
 356                 (unless (zerop gc-run-time)
 357                   (/ (float gc-run-time)
 358                      (float internal-time-units-per-second)))
 359                 (max (- new-page-faults old-page-faults) 0)
 360                 (max (- new-bytes-consed old-bytes-consed) 0)))))))