#!+largefile "lseek_largefile"
(function off-t int off-t int))
fd offset whence)))
- (if (minusp result )
+ (if (minusp result)
(values nil (get-errno))
(values result 0))))
(defun unix-read (fd buf len)
(declare (type unix-fd fd)
(type (unsigned-byte 32) len))
-
(int-syscall ("read" int (* char) int) fd buf len))
;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
(defun unix-write (fd buf offset len)
(declare (type unix-fd fd)
(type (unsigned-byte 32) offset len))
- (int-syscall ("write" int (* char) int)
- fd
- (with-alien ((ptr (* char) (etypecase buf
- ((simple-array * (*))
- (vector-sap buf))
- (system-area-pointer
- buf))))
- (addr (deref ptr offset)))
- len))
+ (flet ((%write (sap)
+ (declare (system-area-pointer sap))
+ (int-syscall ("write" int (* char) int)
+ fd
+ (with-alien ((ptr (* char) sap))
+ (addr (deref ptr offset)))
+ len)))
+ (etypecase buf
+ ((simple-array * (*))
+ (with-pinned-objects (buf)
+ (%write (vector-sap buf))))
+ (system-area-pointer
+ (%write buf)))))
;;; Set up a unix-piping mechanism consisting of an input pipe and an
;;; output pipe. Return two values: if no error occurred the first
\f
;;;; sys/select.h
+(defvar *on-dangerous-select* :warn)
+
+;;; Calling select in a bad place can hang in a nasty manner, so it's better
+;;; to have some way to detect these.
+(defun note-dangerous-select ()
+ (let ((action *on-dangerous-select*)
+ (*on-dangerous-select* nil))
+ (case action
+ (:warn
+ (warn "Starting a select without a timeout while interrupts are ~
+ disabled."))
+ (:error
+ (error "Starting a select without a timeout while interrupts are ~
+ disabled."))
+ (:backtrace
+ (write-line
+ "=== Starting a select without a timeout while interrupts are disabled. ==="
+ *debug-io*)
+ (sb!debug:backtrace)))
+ nil))
+
;;;; FIXME: Why have both UNIX-SELECT and UNIX-FAST-SELECT?
;;; Perform the UNIX select(2) system call.
-(declaim (inline unix-fast-select)) ; (used to be a macro in CMU CL)
+(declaim (inline unix-fast-select))
(defun unix-fast-select (num-descriptors
read-fds write-fds exception-fds
- timeout-secs &optional (timeout-usecs 0))
+ timeout-secs timeout-usecs)
(declare (type (integer 0 #.fd-setsize) num-descriptors)
(type (or (alien (* (struct fd-set))) null)
read-fds write-fds exception-fds)
- (type (or null (unsigned-byte 31)) timeout-secs)
- (type (unsigned-byte 31) timeout-usecs))
- ;; FIXME: CMU CL had
- ;; (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
- ;; here. Is that important for SBCL? If so, why? Profiling might tell us..
- (with-alien ((tv (struct timeval)))
- (when timeout-secs
- (setf (slot tv 'tv-sec) timeout-secs)
- (setf (slot tv 'tv-usec) timeout-usecs))
- (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
- (* (struct fd-set)) (* (struct timeval)))
- num-descriptors read-fds write-fds exception-fds
- (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))
+ (type (or null (unsigned-byte 31)) timeout-secs timeout-usecs))
+ (flet ((select (tv-sap)
+ (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (* (struct fd-set)) (* (struct timeval)))
+ num-descriptors read-fds write-fds exception-fds
+ tv-sap)))
+ (cond ((or timeout-secs timeout-usecs)
+ (with-alien ((tv (struct timeval)))
+ (setf (slot tv 'tv-sec) (or timeout-secs 0))
+ (setf (slot tv 'tv-usec) (or timeout-usecs 0))
+ (select (alien-sap (addr tv)))))
+ (t
+ (unless *interrupts-enabled*
+ (note-dangerous-select))
+ (select (int-sap 0))))))
;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
;;; to happen on one of them or to time out.
(rdf (struct fd-set))
(wrf (struct fd-set))
(xpf (struct fd-set)))
- (when to-secs
- (setf (slot tv 'tv-sec) to-secs)
- (setf (slot tv 'tv-usec) to-usecs))
+ (cond (to-secs
+ (setf (slot tv 'tv-sec) to-secs
+ (slot tv 'tv-usec) to-usecs))
+ ((not *interrupts-enabled*)
+ (note-dangerous-select)))
(num-to-fd-set rdf rdfds)
(num-to-fd-set wrf wrfds)
(num-to-fd-set xpf xpfds)
(int-sap 0)
(alien-sap (addr ,alienvar)))))
(syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
- (* (struct fd-set)) (* (struct timeval)))
+ (* (struct fd-set)) (* (struct timeval)))
(values result
(fd-set-to-num nfds rdf)
(fd-set-to-num nfds wrf)
(struct wrapped_stat
(st-dev #!-(or mips largefile) unsigned-int
#!+mips unsigned-long
- #!+largefile dev-t)
+ #!+(and largefile (not mips)) dev-t)
(st-ino ino-t)
(st-mode mode-t)
(st-nlink nlink-t)
(st-gid gid-t)
(st-rdev #!-(or mips largefile) unsigned-int
#!+mips unsigned-long
- #!+largefile dev-t)
+ #!+(and largefile (not mips)) dev-t)
(st-size #!-(or darwin mips largefile) unsigned-int
#!+(or darwin mips largefile) off-t)
#!+(and darwin)
(return pathname)
(push pathname previous-pathnames))))
\f
+
+(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
- (defconstant micro-seconds-per-internal-time-unit
- (/ 1000000 sb!xc:internal-time-units-per-second))
-
- (declaim (inline system-internal-real-time system-internal-run-time))
- (defun system-internal-real-time ()
- (multiple-value-bind (ignore seconds useconds) (unix-gettimeofday)
- (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
- (let ((uint (truncate useconds
- micro-seconds-per-internal-time-unit)))
- (declare (type (unsigned-byte 32) uint))
- (+ (* seconds sb!xc:internal-time-units-per-second)
- uint))))
+ (declaim (inline system-internal-run-time
+ system-real-time-values))
+
+ (defun system-real-time-values ()
+ (multiple-value-bind (_ sec usec) (unix-gettimeofday)
+ (declare (ignore _) (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
+ (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)
projects / sbcl.git / blobdiff