home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / time.lisp < prev    next >
Encoding:
Text File  |  1992-08-05  |  13.5 KB  |  388 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; 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.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: time.lisp,v 1.13 92/08/05 20:08:28 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains the definitions for the Spice Lisp time functions.
  15. ;;; They are mostly fairly straightforwardly implemented as calls to the 
  16. ;;; time server.
  17. ;;;
  18. ;;;    Written by Rob MacLachlan.
  19. ;;;
  20. (in-package 'lisp)
  21. (export '(internal-time-units-per-second get-internal-real-time
  22.       get-internal-run-time get-universal-time
  23.       get-decoded-time encode-universal-time decode-universal-time))
  24.  
  25. (defconstant internal-time-units-per-second 100
  26.   "The number of internal time units that fit into a second.  See
  27.   Get-Internal-Real-Time and Get-Internal-Run-Time.")
  28.  
  29. (defconstant micro-seconds-per-internal-time-unit
  30.   (/ 1000000 internal-time-units-per-second))
  31.  
  32.  
  33. (defmacro not-leap-year (year)
  34.   (let ((sym (gensym)))
  35.     `(let ((,sym ,year))
  36.        (cond ((eq (mod ,sym 4) 0)
  37.           (and (eq (mod ,sym 100) 0)
  38.            (not (eq (mod ,sym 400) 0))))
  39.          (T T)))))
  40.  
  41.  
  42. ;;; The base number of seconds for our internal "epoch".  We initialize this to
  43. ;;; the time of the first call to G-I-R-T, and then subtract this out of the
  44. ;;; result.
  45. ;;;
  46. (defvar *internal-real-time-base-seconds* nil)
  47. (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
  48.  
  49. ;;; Get-Internal-Real-Time  --  Public
  50. ;;;
  51. (defun get-internal-real-time ()
  52.   "Return the real time in the internal time format.  This is useful for
  53.   finding elapsed time.  See Internal-Time-Units-Per-Second."
  54.   (locally (declare (optimize (speed 3) (safety 0)))
  55.     (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
  56.       (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
  57.       (let ((base *internal-real-time-base-seconds*)
  58.         (uint (truncate useconds
  59.                 micro-seconds-per-internal-time-unit)))
  60.     (declare (type (unsigned-byte 32) uint))
  61.     (cond (base
  62.            (truly-the (unsigned-byte 32)
  63.             (+ (the (unsigned-byte 32)
  64.                 (* (the (unsigned-byte 32) (- seconds base))
  65.                    internal-time-units-per-second))
  66.                uint)))
  67.           (t
  68.            (setq *internal-real-time-base-seconds* seconds)
  69.            uint))))))
  70.  
  71.  
  72. ;;; Get-Internal-Run-Time  --  Public
  73. ;;;
  74. (defun get-internal-run-time ()
  75.   "Return the run time in the internal time format.  This is useful for
  76.   finding CPU usage."
  77.   (declare (values (unsigned-byte 32)))
  78.   (locally (declare (optimize (speed 3) (safety 0)))
  79.     (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
  80.              (unix:unix-fast-getrusage unix:rusage_self)
  81.       (declare (ignore ignore)
  82.            (type (unsigned-byte 31) utime-sec stime-sec)
  83.            (type (mod 1000000) utime-usec stime-usec))
  84.       (+ (the (unsigned-byte 32)
  85.           (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
  86.          internal-time-units-per-second))
  87.      (truncate (+ utime-usec stime-usec)
  88.            micro-seconds-per-internal-time-unit)))))
  89.  
  90.  
  91. ;;; Subtract from the returned Internal_Time to get the universal time.
  92. ;;; The offset between our time base and the Perq one is 2145 weeks and
  93. ;;; five days.
  94. ;;;
  95. (defconstant seconds-in-week (* 60 60 24 7))
  96. (defconstant weeks-offset 2145)
  97. (defconstant seconds-offset 432000)
  98. (defconstant minutes-per-day (* 24 60))
  99. (defconstant quarter-days-per-year (1+ (* 365 4)))
  100. (defconstant quarter-days-per-century 146097)
  101. (defconstant november-17-1858 678882)
  102. (defconstant weekday-november-17-1858 2)
  103. (defconstant unix-to-universal-time 2208988800)
  104.  
  105. ;;; Make-Universal-Time  --  Internal
  106. ;;;
  107. ;;;    Convert a Unix Internal_Time into a universal time.
  108. ;;;
  109. (defun make-universal-time (weeks msec)
  110.   (+ (* (- weeks weeks-offset) seconds-in-week)
  111.      (- (truncate msec 1000) seconds-offset)))
  112.  
  113.  
  114. ;;; Get-Universal-Time  --  Public
  115. ;;;
  116. ;;;
  117. (defun get-universal-time ()
  118.   "Returns a single integer for the current time of
  119.    day in universal time format."
  120.   (multiple-value-bind (res secs) (unix:unix-gettimeofday)
  121.     (declare (ignore res))
  122.     (+ secs unix-to-universal-time)))
  123.  
  124. (defun get-decoded-time ()
  125.   "Returns nine values specifying the current time as follows:
  126.    second, minute, hour, date, month, year, day of week (0 = Monday), T
  127.    (daylight savings times) or NIL (standard time), and timezone."
  128.   (decode-universal-time (get-universal-time)))
  129.  
  130. (defun decode-universal-time (universal-time &optional time-zone)
  131.   "Converts a universal-time to decoded time format returning the following
  132.   nine values: second, minute, hour, date, month, year, day of week (0 =
  133.   Monday), T (daylight savings time) or NIL (standard time), and timezone.
  134.   Completely ignores daylight-savings-time when time-zone is supplied."
  135.   (declare (type (or fixnum null) time-zone))
  136.   (multiple-value-bind (weeks secs)
  137.                (truncate (+ universal-time seconds-offset)
  138.                  seconds-in-week)
  139.     (let ((weeks (+ weeks weeks-offset))
  140.       (second NIL)
  141.       (minute NIL)
  142.       (hour NIL)
  143.       (date NIL)
  144.       (month NIL)
  145.       (year NIL)
  146.       (day NIL)
  147.       (daylight NIL)
  148.       (timezone (if (null time-zone)
  149.             (multiple-value-bind (res s us tz)
  150.                          (unix:unix-gettimeofday)
  151.               (declare (ignore s us))
  152.               (if res tz 0))
  153.             (* time-zone 60))))
  154.       (declare (fixnum timezone))
  155.       (multiple-value-bind (t1 seconds) (truncate secs 60)
  156.     (setq second seconds)
  157.     (setq t1 (- t1 timezone))
  158.     (let* ((tday (if (< t1 0)
  159.              (1- (truncate (1+ t1) minutes-per-day))
  160.              (truncate t1 minutes-per-day))))
  161.       (multiple-value-setq (hour minute)
  162.         (truncate (- t1 (* tday minutes-per-day)) 60))
  163.       (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
  164.          (tcent (truncate t2 quarter-days-per-century)))
  165.         (setq t2 (mod t2 quarter-days-per-century))
  166.         (setq t2 (+ (- t2 (mod t2 4)) 3))
  167.         (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
  168.         (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
  169.                          4))))
  170.           (setq day (mod (+ tday weekday-november-17-1858) 7))
  171.           (unless time-zone
  172.         (if (setq daylight (dst-check days-since-mar0 hour day))
  173.             (cond ((eq hour 23)
  174.                (setq hour 0)
  175.                (setq day (mod (1+ day) 7))
  176.                (setq days-since-mar0 (1+ days-since-mar0))
  177.                (if (>= days-since-mar0 366)
  178.                    (if (or (> days-since-mar0 366)
  179.                        (not-leap-year (1+ year)))
  180.                    (setq days-since-mar0 368))))
  181.               (T (setq hour (1+ hour))))))
  182.           (let ((t3 (+ (* days-since-mar0 5) 456)))
  183.         (cond ((>= t3 1989)
  184.                (setq t3 (- t3 1836))
  185.                (setq year (1+ year))))
  186.         (multiple-value-setq (month t3) (truncate t3 153))
  187.         (setq date (1+ (truncate t3 5))))))))
  188.       (values second minute hour date month year day
  189.           daylight (truncate timezone 60)))))
  190.  
  191. ;;; Encode-Universal-Time  --  Public
  192. ;;;
  193. ;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we 
  194. ;;; have to figure out which the "obvious" year is.
  195. ;;;
  196.  
  197. (defun encode-universal-time (second minute hour date month year
  198.                      &optional time-zone)
  199.   "The time values specified in decoded format are converted to 
  200.    universal time, which is returned."
  201.   (let* ((year (if (< year 100)
  202.            (multiple-value-bind (sec min hour day month now-year)
  203.                     (get-decoded-time)
  204.              (declare (ignore sec min hour day month))
  205.              (do ((y (+ year (* 100 (1- (truncate now-year 100))))
  206.                  (+ y 100)))
  207.              ((<= (abs (- y now-year)) 50) y)))
  208.            year))
  209.      (zone (if time-zone (* time-zone 60)
  210.            (multiple-value-bind (res s us tz) (unix:unix-gettimeofday)
  211.              (declare (ignore s us))
  212.              (if res tz))))
  213.      (tmonth (- month 3)))
  214.     (cond ((< tmonth 0)
  215.        (setq tmonth (+ tmonth 12))
  216.        (setq year (1- year))))
  217.     (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
  218.       (multiple-value-bind (tcent tyear) (truncate year 100)
  219.     (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
  220.                (truncate (* tyear quarter-days-per-year) 4)
  221.                days-since-mar0)
  222.             november-17-1858))
  223.            (daylight (dst-check days-since-mar0 (1- hour)
  224.                     (mod (+ tday weekday-november-17-1858) 7)))
  225.            (tminutes (+ (* hour 60) minute zone)))
  226.       (if daylight (setq tminutes (- tminutes 60)))
  227.       (do ((i tminutes (+ i minutes-per-day)))
  228.           ((>= i 0) (setq tminutes i))
  229.         (declare (fixnum i))
  230.         (decf tday 1))
  231.       (do ((i tminutes (- i minutes-per-day)))
  232.           ((< i minutes-per-day) (setq tminutes i))
  233.         (declare (fixnum i))
  234.         (incf tday 1))
  235.       (multiple-value-bind (weeks dpart) (truncate tday 7)
  236.         (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
  237.                            tminutes) 60)
  238.                          second) 1000))))))))
  239.  
  240. ;;; Dst-check -- Internal
  241. (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
  242. (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
  243.  
  244. (eval-when (compile eval)
  245.   
  246.   (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
  247.     (let ((d (gensym))
  248.       (h (gensym))
  249.       (w (gensym))
  250.       (db (gensym)))
  251.       `(let ((,d ,day)
  252.          (,h ,hour)
  253.          (,w ,weekday)
  254.          (,db ,daybound))
  255.      (declare (fixnum ,d ,h ,w ,db))
  256.      (cond ((< ,d ,db) NIL)
  257.            ((> (the fixnum (- ,d ,w)) ,db) T)
  258.            ((and (eq ,w 6) (> ,h 0)) T)
  259.            (T NIL)))))
  260.   
  261.   (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
  262.     (let ((d (gensym))
  263.       (h (gensym))
  264.       (w (gensym))
  265.       (db (gensym)))
  266.       `(let ((,d ,day)
  267.          (,h ,hour)
  268.          (,w ,weekday)
  269.          (,db ,daybound))
  270.      (declare (fixnum ,d ,h ,w ,db))
  271.      (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
  272.            ((> (the fixnum  (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
  273.            ((and (eq ,w 6) (> ,h 0)) T)
  274.            (T NIL)))))
  275.   )
  276.  
  277. (defun dst-check (day hour weekday)
  278.   (and (dst-check-start-of-month-ge day hour weekday april-1)
  279.        (not (dst-check-end-of-month-ge day hour weekday october-31))))
  280.  
  281. ;;;; Time:
  282.  
  283. (defmacro time (form)
  284.   "Evaluates the Form and prints timing information on *Trace-Output*."
  285.   `(%time #'(lambda () ,form)))
  286.  
  287. ;;; MASSAGE-TIME-FUNCTION  --  Internal
  288. ;;;
  289. ;;;    Try to compile the closure arg to %TIME if it is interpreted.
  290. ;;;
  291. (defun massage-time-function (fun)
  292.   (cond
  293.    ((eval:interpreted-function-p fun)
  294.     (multiple-value-bind (def env-p)
  295.              (function-lambda-expression fun)
  296.       (declare (ignore def))
  297.       (cond
  298.        (env-p
  299.     (warn "TIME form in a non-null environment, forced to interpret.~@
  300.            Compiling entire form will produce more accurate times.")
  301.     fun)
  302.        (t
  303.     (compile nil fun)))))
  304.    (t fun)))
  305.  
  306. ;;; TIME-GET-SYS-INFO  --  Internal
  307. ;;;
  308. ;;;    Return all the files that we want time to report.
  309. ;;;
  310. (defun time-get-sys-info ()
  311.   (multiple-value-bind (user sys faults)
  312.                (system:get-system-info)
  313.     (values user sys faults (get-bytes-consed))))
  314.  
  315. ;;; %TIME  --  Internal
  316. ;;;
  317. ;;;    The guts of the TIME macro.  Compute overheads, run the (compiled)
  318. ;;; function, report the times.
  319. ;;;
  320. (defun %time (fun)
  321.   (let ((fun (massage-time-function fun))
  322.     old-run-utime
  323.         new-run-utime
  324.         old-run-stime
  325.         new-run-stime
  326.         old-real-time
  327.         new-real-time
  328.         old-page-faults
  329.         new-page-faults
  330.         real-time-overhead
  331.         run-utime-overhead
  332.         run-stime-overhead
  333.         page-faults-overhead
  334.         old-bytes-consed
  335.         new-bytes-consed
  336.         cons-overhead)
  337.     ;; Calculate the overhead...
  338.     (multiple-value-setq
  339.         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
  340.       (time-get-sys-info))
  341.     ;; Do it a second time to make sure everything is faulted in.
  342.     (multiple-value-setq
  343.         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
  344.       (time-get-sys-info))
  345.     (multiple-value-setq
  346.         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
  347.       (time-get-sys-info))
  348.     (setq run-utime-overhead (- new-run-utime old-run-utime))
  349.     (setq run-stime-overhead (- new-run-stime old-run-stime))
  350.     (setq page-faults-overhead (- new-page-faults old-page-faults))
  351.     (setq old-real-time (get-internal-real-time))
  352.     (setq old-real-time (get-internal-real-time))
  353.     (setq new-real-time (get-internal-real-time))
  354.     (setq real-time-overhead (- new-real-time old-real-time))
  355.     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
  356.     ;; Now get the initial times.
  357.     (multiple-value-setq
  358.         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
  359.       (time-get-sys-info))
  360.     (setq old-real-time (get-internal-real-time))
  361.     (let ((start-gc-run-time *gc-run-time*))
  362.     (multiple-value-prog1
  363.         ;; Execute the form and return its values.
  364.         (funcall fun)
  365.       (multiple-value-setq
  366.       (new-run-utime new-run-stime new-page-faults new-bytes-consed)
  367.     (time-get-sys-info))
  368.       (setq new-real-time (- (get-internal-real-time) real-time-overhead))
  369.       (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
  370.     (format *trace-output*
  371.         "~&Evaluation took:~%  ~
  372.          ~S second~:P of real time~%  ~
  373.          ~S second~:P of user run time~%  ~
  374.          ~S second~:P of system run time~%  ~
  375.          ~@[[Run times include ~S second~:P GC run time]~%  ~]~
  376.          ~S page fault~:P and~%  ~
  377.          ~S bytes consed.~%"
  378.         (max (/ (- new-real-time old-real-time)
  379.             (float internal-time-units-per-second))
  380.              0.0)
  381.         (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
  382.         (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
  383.         (unless (zerop gc-run-time)
  384.           (/ (float gc-run-time)
  385.              (float internal-time-units-per-second)))
  386.         (max (- new-page-faults old-page-faults) 0)
  387.         (max (- new-bytes-consed old-bytes-consed) 0)))))))
  388.