X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=7021ce4a130a27d9e45822ad5c48fa8648a09314;hb=ad6345c0021507c8830c7c8541ed651a89792335;hp=2423d6c7b4a7c3bc560319bb7ef6775c7bcbb620;hpb=8c685e1fee08b4d1d9ef43b8d2784ac283c94096;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 2423d6c..7021ce4 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -47,7 +47,7 @@ ;;;; Lisp types used by syscalls -(deftype unix-pathname () 'simple-base-string) +(deftype unix-pathname () 'simple-string) (deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) @@ -107,26 +107,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!+win32 (progn - (defconstant o_rdonly 0) - (defconstant o_wronly 1) - (defconstant o_rdwr 2) - (defconstant o_creat #x100) - (defconstant o_trunc #x200) - (defconstant o_append #x008) - (defconstant o_excl #x400) - (defconstant enoent 2) - (defconstant eexist 17) (defconstant espipe 29) - (defconstant o_binary #x8000) - (defconstant s-ifmt #xf000) - (defconstant s-ifdir #x4000) - (defconstant s-ifreg #x8000) - (define-alien-type ino-t short) - (define-alien-type time-t long) - (define-alien-type off-t long) - (define-alien-type size-t long) - (define-alien-type mode-t unsigned-short) - ;; For stat-wrapper hack (different-type or non-existing win32 fields). (define-alien-type nlink-t short) (define-alien-type uid-t short) @@ -134,6 +115,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; hacking the Unix environment +#!-win32 (define-alien-routine ("getenv" posix-getenv) c-string "Return the \"value\" part of the environment string \"name=value\" which corresponds to NAME, or NIL if there is none." @@ -143,6 +125,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Rename the file with string NAME1 to the string NAME2. NIL and an ;;; error code is returned if an error occurs. +#!-win32 (defun unix-rename (name1 name2) (declare (type unix-pathname name1 name2)) (void-syscall ("rename" c-string c-string) name1 name2)) @@ -184,7 +167,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (type unix-pathname path) (type fixnum flags) (type unix-file-mode mode)) - (int-syscall ("open" c-string int int) path (logior #!+win32 o_binary flags) mode)) + (int-syscall ("open" c-string int int) + path + (logior #!+win32 o_binary + #!+largefile o_largefile + flags) + mode)) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file ;;; associated with it. @@ -197,10 +185,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; A time value that is accurate to the nearest ;; microsecond but also has a range of years. +;; CLH: Note that tv-usec used to be a time-t, but that this seems +;; problematic on Darwin x86-64 (and wrong). Trying suseconds-t. +#!-win32 (define-alien-type nil (struct timeval - (tv-sec time-t) ; seconds - (tv-usec time-t))) ; and microseconds + (tv-sec time-t) ; seconds + (tv-usec suseconds-t))) ; and microseconds + +#!+win32 +(define-alien-type nil + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec long))) ; and microseconds ;;;; resourcebits.h @@ -239,7 +236,16 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; w_ok Write permission. ;;; x_ok Execute permission. ;;; f_ok Presence of file. -#!-win32 + +;;; In Windows, the MODE argument to access is defined in terms of +;;; literal magic numbers---there are no constants to grovel. X_OK +;;; is not defined. +#!+win32 +(progn + (defconstant f_ok 0) + (defconstant w_ok 2) + (defconstant r_ok 4)) + (defun unix-access (path mode) (declare (type unix-pathname path) (type (mod 8) mode)) @@ -265,7 +271,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." " (declare (type unix-fd fd) (type (integer 0 2) whence)) - (let ((result (alien-funcall (extern-alien "lseek" (function off-t int off-t int)) + (let ((result (alien-funcall (extern-alien #!-largefile "lseek" + #!+largefile "lseek_largefile" + (function off-t int off-t int)) fd offset whence))) (if (minusp result ) (values nil (get-errno)) @@ -278,7 +286,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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 @@ -288,15 +295,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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 @@ -309,11 +320,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (syscall ("pipe" (* int)) (values (deref fds 0) (deref fds 1)) (cast fds (* int))))) +#!+win32 +(defun msvcrt-raw-pipe (fds size mode) + (syscall ("_pipe" (* int) int int) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int)) size mode)) +#!+win32 +(defun unix-pipe () + (with-alien ((fds (array int 2))) + (msvcrt-raw-pipe fds 256 o_binary))) ;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could ;; actually call it passing the mode argument, but some sharp-eyed reader ;; would put five and twenty-seven together and ask us about it, so... ;; -- AB, 2005-12-27 +#!-win32 (defun unix-mkdir (name mode) (declare (type unix-pathname name) (type unix-file-mode mode) @@ -332,6 +353,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Return the Unix current directory as a SIMPLE-STRING, in the ;;; style returned by getcwd() (no trailing slash character). +#!-win32 (defun posix-getcwd () ;; This implementation relies on a BSD/Linux extension to getcwd() ;; behavior, automatically allocating memory when a null buffer @@ -511,29 +533,52 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; 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. @@ -573,9 +618,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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) @@ -584,7 +631,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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) @@ -611,23 +658,22 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; longer than 32 bits anyway, right?":-| (define-alien-type nil (struct wrapped_stat - #!-mips - (st-dev unsigned-int) ; would be dev-t in a real stat - #!+mips - (st-dev unsigned-long) ; this is _not_ a dev-t on mips + (st-dev #!-(or mips largefile) unsigned-int + #!+mips unsigned-long + #!+largefile dev-t) (st-ino ino-t) (st-mode mode-t) (st-nlink nlink-t) (st-uid uid-t) (st-gid gid-t) - #!-mips - (st-rdev unsigned-int) ; would be dev-t in a real stat - #!+mips - (st-rdev unsigned-long) ; this is _not_ a dev-t on mips - #!-mips - (st-size unsigned-int) ; would be off-t in a real stat - #!+mips - (st-size off-t) + (st-rdev #!-(or mips largefile) unsigned-int + #!+mips unsigned-long + #!+largefile dev-t) + (st-size #!-(or darwin mips largefile) unsigned-int + #!+(or darwin mips largefile) off-t) + #!+(and darwin) + (st-blksize unsigned-int) + #!-(and darwin) (st-blksize unsigned-long) (st-blocks unsigned-long) (st-atime time-t) @@ -751,6 +797,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; doesn't work, it returns NIL and the errno. #!-sb-fluid (declaim (inline unix-gettimeofday)) (defun unix-gettimeofday () + #!+(and x86-64 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. I can't + ;; find any instances in the SBCL where we actually ues the + ;; timezone values, so we just punt for the moment. + (syscall* ("gettimeofday" (* (struct timeval)) + (* (struct timezone))) + (values t + (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)) @@ -845,7 +906,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-file-kind (name &optional check-for-links) #!+sb-doc "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (declare (simple-base-string name)) + (declare (simple-string name)) (multiple-value-bind (res dev ino mode) (if check-for-links (unix-lstat name) (unix-stat name)) (declare (type (or fixnum null) mode) @@ -871,7 +932,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; paths have been converted to absolute paths, so we don't need to ;;; try to handle any more generality than that. (defun unix-resolve-links (pathname) - (declare (type simple-base-string pathname)) + (declare (type simple-string pathname)) ;; KLUDGE: The Win32 platform doesn't have symbolic links, so ;; short-cut this computation (and the check for being an absolute ;; unix pathname...) @@ -880,8 +941,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; KLUDGE: readlink and lstat are unreliable if given symlinks ;; ending in slashes -- fix the issue here instead of waiting for ;; libc to change... + ;; + ;; but be careful! Must not strip the final slash from "/". (This + ;; adjustment might be a candidate for being transferred into the C + ;; code in a wrap_readlink() function, too.) CSR, 2006-01-18 (let ((len (length pathname))) - (when (and (plusp len) (eql #\/ (schar pathname (1- len)))) + (when (and (> len 1) (eql #\/ (schar pathname (1- len)))) (setf pathname (subseq pathname 0 (1- len))))) (/noshow "entering UNIX-RESOLVE-LINKS") (loop with previous-pathnames = nil do @@ -900,14 +965,14 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if (null link) (return pathname) (let ((new-pathname - (unix-simplify-pathname + (simplify-namestring (if (relative-unix-pathname? link) (let* ((dir-len (1+ (position #\/ pathname :from-end t))) (dir (subseq pathname 0 dir-len))) (/noshow dir) - (concatenate 'base-string dir link)) + (concatenate 'string dir link)) link)))) (if (unix-file-kind new-pathname) (setf pathname new-pathname) @@ -921,92 +986,82 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if (member pathname previous-pathnames :test #'string=) (return pathname) (push pathname previous-pathnames)))) + -(defun unix-simplify-pathname (src) - (declare (type simple-base-string src)) - (let* ((src-len (length src)) - (dst (make-string src-len :element-type 'base-char)) - (dst-len 0) - (dots 0) - (last-slash nil)) - (macrolet ((deposit (char) - `(progn - (setf (schar dst dst-len) ,char) - (incf dst-len)))) - (dotimes (src-index src-len) - (let ((char (schar src src-index))) - (cond ((char= char #\.) - (when dots - (incf dots)) - (deposit char)) - ((char= char #\/) - (case dots - (0 - ;; either ``/...' or ``...//...' - (unless last-slash - (setf last-slash dst-len) - (deposit char))) - (1 - ;; either ``./...'' or ``..././...'' - (decf dst-len)) - (2 - ;; We've found .. - (cond - ((and last-slash (not (zerop last-slash))) - ;; There is something before this .. - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (cond ((and (= (+ (or prev-prev-slash 0) 2) - last-slash) - (char= (schar dst (- last-slash 2)) #\.) - (char= (schar dst (1- last-slash)) #\.)) - ;; The something before this .. is another .. - (deposit char) - (setf last-slash dst-len)) - (t - ;; The something is some directory or other. - (setf dst-len - (if prev-prev-slash - (1+ prev-prev-slash) - 0)) - (setf last-slash prev-prev-slash))))) - (t - ;; There is nothing before this .., so we need to keep it - (setf last-slash dst-len) - (deposit char)))) - (t - ;; something other than a dot between slashes - (setf last-slash dst-len) - (deposit char))) - (setf dots 0)) - (t - (setf dots nil) - (setf (schar dst dst-len) char) - (incf dst-len)))))) - (when (and last-slash (not (zerop last-slash))) - (case dots - (1 - ;; We've got ``foobar/.'' - (decf dst-len)) - (2 - ;; We've got ``foobar/..'' - (unless (and (>= last-slash 2) - (char= (schar dst (1- last-slash)) #\.) - (char= (schar dst (- last-slash 2)) #\.) - (or (= last-slash 2) - (char= (schar dst (- last-slash 3)) #\/))) - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (if prev-prev-slash - (setf dst-len (1+ prev-prev-slash)) - (return-from unix-simplify-pathname - (coerce "./" 'simple-base-string)))))))) - (cond ((zerop dst-len) - "./") - ((= dst-len src-len) - dst) - (t - (subseq dst 0 dst-len))))) +(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 + (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) + (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)))) ;;;; A magic constant for wait3(). ;;;; @@ -1059,3 +1114,4 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(progn ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) +