source: branches/win64/lib/time.lisp @ 8837

Last change on this file since 8837 was 8837, checked in by gb, 13 years ago

Conditionalize some TIME/GET-INTERNAL-RUN-TIME stuff for win64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.3 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (defconstant seconds-in-week (* 60 60 24 7))
21  (defconstant weeks-offset 2145)
22  (defconstant seconds-offset 432000)
23  (defconstant minutes-per-day (* 24 60))
24  (defconstant quarter-days-per-year (1+ (* 365 4)))
25  (defconstant quarter-days-per-century 146097)
26  (defconstant november-17-1858 678882)
27  (defconstant weekday-november-17-1858 2)
28)
29
30(defun gctime ()
31  (let* ((timeval-size (record-length :timeval)))
32    (%stack-block ((copy (* timeval-size 5)))
33      (#_memmove copy *total-gc-microseconds* (* timeval-size 5))
34      (macrolet ((funk (arg)
35                   (ecase internal-time-units-per-second 
36                    (1000000 `(timeval->microseconds ,arg))
37                    (1000 `(timeval->milliseconds ,arg)))))
38        (values
39         (funk copy)
40         (funk (%incf-ptr copy timeval-size))
41         (funk (%incf-ptr copy timeval-size))
42         (funk (%incf-ptr copy timeval-size))
43         (funk (%incf-ptr copy timeval-size)))))))
44
45(defun get-universal-time ()
46  "Return a single integer for the current time of
47   day in universal time format."
48  #-windows-target
49  (rlet ((tv :timeval))
50    (#_gettimeofday tv (%null-ptr))
51    (+ (pref tv :timeval.tv_sec) unix-to-universal-time))
52  #+windows-target
53  (rlet ((ft #>FILETIME))
54    (#_GetSystemTimeAsFileTime ft)
55    (windows-filetime-to-universal-time ft)))
56
57
58;;; This should stop using #_localtime_r: not all times can be represented
59;;; as a signed natural offset from the start of Unix time.
60;;; For now, if the time won't fit in a :time_t, use an arbitrary time
61;;; value to get the time zone and assume that DST was -not- in effect.
62#-windows-target
63(defun get-timezone (time)
64  (let* ((toobig (not (typep time '(unsigned-byte
65                                    #+32-bit-target 32
66                                    #+64-bit-target 64)))))
67    (when toobig
68      (setq time 0))
69    (rlet ((when :time_t)
70           (tm :tm))
71      (setf (pref when :time_t) time)
72      (with-macptrs ((ltm (#_localtime_r when tm)))
73        (if (%null-ptr-p ltm)
74          (values 0 nil)
75          (progn
76            (values (floor (pref tm :tm.tm_gmtoff) -60)
77                    (unless toobig (not (zerop (pref tm :tm.tm_isdst)))))))))))
78
79#+windows-target
80(defun get-timezone (time)
81  (declare (ignore time))
82  (rlet ((tzinfo #>TIME_ZONE_INFORMATION))
83    (let* ((id (#_GetTimeZoneInformation tzinfo))
84           (minutes-west (pref tzinfo #>TIME_ZONE_INFORMATION.Bias))
85           (is-dst (= id #$TIME_ZONE_ID_DAYLIGHT)))
86      (values (floor (+ minutes-west
87                        (if is-dst
88                          (pref tzinfo #>TIME_ZONE_INFORMATION.DaylightBias)
89                          0)))
90              is-dst))))
91
92
93
94(defun decode-universal-time (universal-time &optional time-zone)
95  "Converts a universal-time to decoded time format returning the following
96   nine values: second, minute, hour, date, month, year, day of week (0 =
97   Monday), T (daylight savings time) or NIL (standard time), and timezone.
98   Completely ignores daylight-savings-time when time-zone is supplied."
99  (multiple-value-bind (weeks secs)
100                       (truncate (+ universal-time seconds-offset)
101                                 seconds-in-week)
102    (let* ((weeks (+ weeks weeks-offset))
103           (second NIL)
104           (minute NIL)
105           (hour NIL)
106           (date NIL)
107           (month NIL)
108           (year NIL)
109           (day NIL)
110           (daylight NIL)
111           (timezone (if (null time-zone)
112                         (multiple-value-bind
113                             (minwest dst)
114                             (get-timezone (- universal-time
115                                              unix-to-universal-time))
116                           (setf daylight dst)
117                           minwest)
118                         (* time-zone 60))))
119      (declare (fixnum timezone))
120      (multiple-value-bind (t1 seconds) (truncate secs 60)
121        (setq second seconds)
122        (setq t1 (- t1 timezone))
123        (let* ((tday (if (< t1 0)
124                         (1- (truncate (1+ t1) minutes-per-day))
125                         (truncate t1 minutes-per-day))))
126          (multiple-value-setq (hour minute)
127            (truncate (- t1 (* tday minutes-per-day)) 60))
128          (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
129                 (tcent (truncate t2 quarter-days-per-century)))
130            (setq t2 (mod t2 quarter-days-per-century))
131            (setq t2 (+ (- t2 (mod t2 4)) 3))
132            (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
133            (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
134                                                 4))))
135              (setq day (mod (+ tday weekday-november-17-1858) 7))
136              (let ((t3 (+ (* days-since-mar0 5) 456)))
137                (cond ((>= t3 1989)
138                       (setq t3 (- t3 1836))
139                       (setq year (1+ year))))
140                (multiple-value-setq (month t3) (truncate t3 153))
141                (setq date (1+ (truncate t3 5))))))))
142      (values second minute hour date month year day
143              daylight
144              (if daylight
145                  (1+ (/ timezone 60))
146                  (/ timezone 60))))))
147
148(defun get-decoded-time ()
149  "Return nine values specifying the current time as follows:
150   second, minute, hour, date, month, year, day of week (0 = Monday), T
151   (daylight savings times) or NIL (standard time), and timezone."
152  (decode-universal-time (get-universal-time)))
153
154(defun current-year ()
155  (nth-value 5 (get-decoded-time)))
156
157(defun leap-years-before (year)
158  (let ((years (- year 1901)))
159    (+ (- (truncate years 4)
160          (truncate years 100))
161       (truncate (+ years 300) 400))))
162
163(defvar *days-before-month*
164  (let* ((results (list nil)))
165    (let ((sum 0))
166      (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
167        (push sum results)
168        (incf sum days-per-month)))
169    (coerce (nreverse results) 'vector)))
170
171(defun encode-universal-time (second minute hour date month year
172                                     &optional time-zone)
173  "The time values specified in decoded format are converted to
174   universal time, which is returned."
175  (declare (type (mod 60) second)
176           (type (mod 60) minute)
177           (type (mod 24) hour)
178           (type (integer 1 31) date)
179           (type (integer 1 12) month)
180           (type unsigned-byte year)
181           (type (or null rational) time-zone))
182  (when (< year 100)
183    (let* ((this (current-year))
184           (past (- this 50))
185           (future (+ this 49))
186           (maybe-past (+ (- past (mod past 100)) year))
187           (maybe-future (+ (- future (mod future 100)) year)))
188      (if (>= maybe-past past)
189        (setq year maybe-past)
190        (setq year maybe-future))))
191           
192  (let* ((days (+ (1- date)
193                  (aref *days-before-month* month)
194                  (if (> month 2)
195                    (leap-years-before (1+ year))
196                    (leap-years-before year))
197                  (* (- year 1900) 365)))
198         (hours (+ hour (* days 24))))
199    (if time-zone
200      (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
201      (let* ((minwest-guess
202              (get-timezone (- (* hours 60 60)
203                               unix-to-universal-time)))
204             (guess (+ minute (* hours 60) minwest-guess))
205             (minwest
206              (get-timezone (- (* guess 60)
207                               unix-to-universal-time))))
208        (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
209
210
211
212(defun sleep (seconds)
213  "This function causes execution to be suspended for N seconds. N may
214  be any non-negative, non-complex number."
215  (when (minusp seconds) (report-bad-arg seconds '(real 0 *)))
216  #-windows-target
217  (multiple-value-bind (secs nanos)
218      (nanoseconds seconds)
219    (%nanosleep secs nanos))
220  #+windows-target
221  (let* ((millis (round (* seconds 1000))))
222    (#_SleepEx millis 1))
223  )
224
225
226(defun %internal-run-time ()
227  ;; Returns user and system times in internal-time-units as multiple values.
228  #-windows-target
229  (rlet ((usage :rusage))
230    (%%rusage usage)
231    (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec))
232           (system-seconds (pref usage :rusage.ru_stime.tv_sec))
233           (user-micros (pref usage :rusage.ru_utime.tv_usec))
234           (system-micros (pref usage :rusage.ru_stime.tv_usec)))
235      (values (+ (* user-seconds internal-time-units-per-second)
236                 (round user-micros (floor 1000000 internal-time-units-per-second)))
237              (+ (* system-seconds internal-time-units-per-second)
238                 (round system-micros (floor 1000000 internal-time-units-per-second))))))
239  #+windows-target
240  (rlet ((start #>FILETIME)
241         (end #>FILETIME)
242         (kernel #>FILETIME)
243         (user #>FILETIME))
244    (#_GetProcessTimes (#_GetCurrentProcess) start end kernel user)
245    (let* ((user-100ns (dpb (pref user #>FILETIME.dwHighDateTime)
246                            (byte 32 32)
247                            (pref user #>FILETIME.dwLowDateTime)))
248           (kernel-100ns (dpb (pref kernel #>FILETIME.dwHighDateTime)
249                            (byte 32 32)
250                            (pref kernel #>FILETIME.dwLowDateTime)))
251           (convert (floor 10000000 internal-time-units-per-second)))
252      (values (floor user-100ns convert) (floor kernel-100ns convert)))))
253
254(defun get-internal-run-time ()
255  "Return the run time in the internal time format. (See
256  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage."
257  (multiple-value-bind (user sys) (%internal-run-time)
258    (+ user sys)))
259
260
261
262
263
264     
Note: See TracBrowser for help on using the repository browser.