+(defconstant micro-seconds-per-internal-time-unit
+ (/ 1000000 sb!xc:internal-time-units-per-second))
+
+;;; UNIX specific code, that has been cleanly separated from the
+;;; Windows build.
+#!-win32
+(progn
+
+ #!-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.)"
+ #!+darwin
+ (with-alien ((tv (struct timeval)))
+ ;; CLH: FIXME! This seems to be a MacOS bug, but on x86-64/darwin,
+ ;; gettimeofday occasionally fails. passing in a null pointer for the
+ ;; timezone struct seems to work around the problem. NS notes: Darwin
+ ;; manpage says the timezone is not used anymore in their implementation
+ ;; at all.
+ (syscall* ("gettimeofday" (* (struct timeval))
+ (* (struct timezone)))
+ (values (slot tv 'tv-sec)
+ (slot tv 'tv-usec))
+ (addr tv)
+ nil))
+ #!-(and x86-64 darwin)
+ (with-alien ((tv (struct timeval))
+ (tz (struct timezone)))
+ (syscall* ("gettimeofday" (* (struct timeval))
+ (* (struct timezone)))
+ (values (slot tv 'tv-sec)
+ (slot tv 'tv-usec))
+ (addr tv)
+ (addr tz))))
+
+ (declaim (inline system-internal-run-time
+ system-real-time-values))
+
+ (defun system-real-time-values ()
+ (multiple-value-bind (sec usec) (get-time-of-day)
+ (declare (type (unsigned-byte 32) sec usec))
+ (values sec (truncate usec micro-seconds-per-internal-time-unit))))
+
+ ;; There are two optimizations here that actually matter (on 32-bit
+ ;; systems): substract the epoch from seconds and milliseconds
+ ;; separately, as those should remain fixnums for the first 17 years
+ ;; or so of runtime. Also, avoid doing consing a new bignum if the
+ ;; result would be = to the last result given.
+ ;;
+ ;; Note: the next trick would be to spin a separate thread to update
+ ;; a global value once per internal tick, so each individual call to
+ ;; get-internal-real-time would be just a memory read... but that is
+ ;; probably best left for user-level code. ;)
+ ;;
+ ;; Thanks to James Anderson for the optimization hint.
+ ;;
+ ;; Yes, it is possible to a computation to be GET-INTERNAL-REAL-TIME
+ ;; bound.
+ ;;
+ ;; --NS 2007-04-05
+ (let ((e-sec 0)
+ (e-msec 0)
+ (c-sec 0)
+ (c-msec 0)
+ (now 0))
+ (declare (type (unsigned-byte 32) e-sec c-sec)
+ (type fixnum e-msec c-msec)
+ (type unsigned-byte now))
+ (defun reinit-internal-real-time ()
+ (setf (values e-sec e-msec) (system-real-time-values)
+ c-sec 0
+ c-msec 0))
+ ;; If two threads call this at the same time, we're still safe, I
+ ;; believe, as long as NOW is updated before either of C-MSEC or
+ ;; C-SEC. Same applies to interrupts. --NS
+ ;;
+ ;; I believe this is almost correct with x86/x86-64 cache
+ ;; coherency, but if the new value of C-SEC, C-MSEC can become
+ ;; visible to another CPU without NOW doing the same then it's
+ ;; unsafe. It's `almost' correct on x86 because writes by other
+ ;; processors may become visible in any order provided transitity
+ ;; holds. With at least three cpus, C-MSEC and C-SEC may be from
+ ;; different threads and an incorrect value may be returned.
+ ;; Considering that this failure is not detectable by the caller -
+ ;; it looks like time passes a bit slowly - and that it should be
+ ;; an extremely rare occurance I'm inclinded to leave it as it is.
+ ;; --MG
+ (defun get-internal-real-time ()
+ (multiple-value-bind (sec msec) (system-real-time-values)
+ (unless (and (= msec c-msec) (= sec c-sec))
+ (setf now (+ (* (- sec e-sec)
+ sb!xc:internal-time-units-per-second)
+ (- msec e-msec))
+ c-msec msec
+ c-sec sec))
+ now)))
+
+ (defun system-internal-run-time ()
+ (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
+ (unix-fast-getrusage 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))
+ (let ((result (+ (* (+ 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
+;;; FIXME, KLUDGE: GET-TIME-OF-DAY used to be UNIX-GETTIMEOFDAY, and had a
+;;; primary return value indicating sucess, and also returned timezone
+;;; information -- though the timezone data was not there on Darwin.
+;;; Now we have GET-TIME-OF-DAY, but it turns out that despite SB-UNIX being
+;;; an implementation package UNIX-GETTIMEOFDAY has users in the wild.
+;;; So we're stuck with it for a while -- maybe delete it towards the end
+;;; of 2009.
+(defun unix-gettimeofday ()
+ (multiple-value-bind (sec usec) (get-time-of-day)
+ (values t sec usec nil nil)))
+\f
+;;;; opendir, readdir, closedir, and dirent-name
+
+(declaim (inline unix-opendir))
+(defun unix-opendir (namestring &optional (errorp t))
+ (let ((dir (alien-funcall
+ (extern-alien "sb_opendir"
+ (function system-area-pointer c-string))
+ namestring)))
+ (if (zerop (sap-int dir))
+ (when errorp (simple-perror
+ (format nil "Error opening directory ~S"
+ namestring)))
+ dir)))
+
+(declaim (inline unix-readdir))
+(defun unix-readdir (dir &optional (errorp t) namestring)
+ (let ((ent (alien-funcall
+ (extern-alien "sb_readdir"
+ (function system-area-pointer system-area-pointer))
+ dir)))
+ (if (zerop (sap-int ent))
+ (when errorp (simple-perror
+ (format nil "Error reading directory entry~@[ from ~S~]"
+ namestring)))
+ ent)))
+
+(declaim (inline unix-closedir))
+(defun unix-closedir (dir &optional (errorp t) namestring)
+ (let ((r (alien-funcall
+ (extern-alien "sb_closedir" (function int system-area-pointer))
+ dir)))
+ (if (minusp r)
+ (when errorp (simple-perror
+ (format nil "Error closing directory~@[ ~S~]"
+ namestring)))
+ r)))
+
+(declaim (inline unix-dirent-name))
+(defun unix-dirent-name (ent)
+ (alien-funcall
+ (extern-alien "sb_dirent_name" (function c-string system-area-pointer))
+ ent))