X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=3aef59335d89c05c7d259545dc007ef8969bc75f;hb=77d7fddb855305e783c100bfe9b6b46bdb05e4b6;hp=5049c1e78cd8b32cba151199b37ae9bfceb9d217;hpb=a4a5e8fb87c7af981cb4c759dc3c5e6d44074f42;p=sbcl.git

diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index 5049c1e..3aef593 100644
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -191,7 +191,7 @@
           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
           ;;875       IBM EBCDIC - Modern Greek
-          ;;932       ANSI/OEM - Japanese, Shift-JIS
+          (932 :CP932)     ;; ANSI/OEM - Japanese, Shift-JIS
           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
@@ -486,6 +486,9 @@
 
 ;;;; Process time information
 
+(defconstant 100ns-per-internal-time-unit
+  (/ 10000000 sb!xc:internal-time-units-per-second))
+
 ;; FILETIME
 ;; The FILETIME structure is a 64-bit value representing the number of
 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
@@ -493,22 +496,84 @@
 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
 (define-alien-type FILETIME (sb!alien:unsigned 64))
 
-(defun get-process-times ()
-  (with-alien ((creation-time filetime)
-               (exit-time filetime)
-               (kernel-time filetime)
-               (user-time filetime))
-    (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
-                                             (* filetime) (* filetime))
-              (values creation-time
-                      exit-time
-                      kernel-time
-                      user-time)
-              (get-current-process)
-              (addr creation-time)
-              (addr exit-time)
-              (addr kernel-time)
-              (addr user-time))))
+(defmacro with-process-times ((creation-time exit-time kernel-time user-time)
+                              &body forms)
+  `(with-alien ((,creation-time filetime)
+                (,exit-time filetime)
+                (,kernel-time filetime)
+                (,user-time filetime))
+     (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
+                (* filetime) (* filetime))
+               (progn ,@forms)
+               (get-current-process)
+               (addr ,creation-time)
+               (addr ,exit-time)
+               (addr ,kernel-time)
+               (addr ,user-time))))
+
+(declaim (inline system-internal-real-time))
+
+(let ((epoch 0))
+  (declare (unsigned-byte epoch))
+  ;; FIXME: For optimization ideas see the unix implementation.
+  (defun reinit-internal-real-time ()
+    (setf epoch 0
+          epoch (get-internal-real-time)))
+  (defun get-internal-real-time ()
+    (- (with-alien ((system-time filetime))
+         (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
+                  (values (floor system-time 100ns-per-internal-time-unit))
+                  (addr system-time)))
+       epoch)))
+
+(defun system-internal-run-time ()
+  (with-process-times (creation-time exit-time kernel-time user-time)
+    (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
+
+(define-alien-type hword (unsigned 16))
+
+(define-alien-type systemtime
+    (struct systemtime
+            (year hword)
+            (month hword)
+            (weekday hword)
+            (day hword)
+            (hour hword)
+            (minute hword)
+            (second hword)
+            (millisecond hword)))
+
+;; Obtained with, but the XC can't deal with that -- but
+;; it's not like the value is ever going to change...
+;; (with-alien ((filetime filetime)
+;;              (epoch systemtime))
+;;   (setf (slot epoch 'year) 1970
+;;         (slot epoch 'month) 1
+;;         (slot epoch 'day) 1
+;;         (slot epoch 'hour) 0
+;;         (slot epoch 'minute) 0
+;;         (slot epoch 'second) 0
+;;         (slot epoch 'millisecond) 0)
+;;   (syscall (("SystemTimeToFileTime" 8) void
+;;             (* systemtime) (* filetime))
+;;            filetime
+;;            (addr epoch)
+;;            (addr filetime)))
+(defconstant +unix-epoch-filetime+ 116444736000000000)
+
+#!-sb-fluid
+(declaim (inline get-time-of-day))
+(defun get-time-of-day ()
+  "Return the number of seconds and microseconds since the beginning of the
+UNIX epoch: January 1st 1970."
+  (with-alien ((system-time filetime))
+    (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
+             (multiple-value-bind (sec 100ns)
+                 (floor (- system-time +unix-epoch-filetime+)
+                        (* 100ns-per-internal-time-unit
+                           internal-time-units-per-second))
+               (values sec (floor 100ns 10)))
+             (addr system-time))))
 
 ;; SETENV
 ;; The SetEnvironmentVariable function sets the contents of the specified