X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=2f1888fa57f0de126c02ec59a4599dd28baffaf1;hb=f369c736b57608402903ce5c59be78a87ef23364;hp=4dce234153bbf9438074fd0824d7a839a4d3d07b;hpb=b387f6ae447b55e203f47fc40af4a36e756fe345;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 4dce234..2f1888f 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -64,21 +64,25 @@ ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. (defmacro syscall ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + `(locally + (declare (optimize (sb!c::float-accuracy 0))) + (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) ,@args))) - (if (minusp result) - (values nil (get-errno)) - ,success-form))) + (if (minusp result) + (values nil (get-errno)) + ,success-form)))) ;;; This is like SYSCALL, but if it fails, signal an error instead of ;;; returning error codes. Should only be used for syscalls that will ;;; never really get an error. (defmacro syscall* ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) - (if (minusp result) - (error "Syscall ~A failed: ~A" ,name (strerror)) - ,success-form))) + `(locally + (declare (optimize (sb!c::float-accuracy 0))) + (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (error "Syscall ~A failed: ~A" ,name (strerror)) + ,success-form)))) (/show0 "unix.lisp 109") @@ -119,7 +123,8 @@ (define-alien-type nil (struct fd-set - (fds-bits (array fd-mask #.(/ fd-setsize 32))))) + (fds-bits (array fd-mask #.(/ fd-setsize + sb!vm:n-machine-word-bits))))) (/show0 "unix.lisp 304") @@ -209,22 +214,21 @@ (declare (type unix-fd fd)) (int-syscall ("isatty" int) fd)) -;;; Accept a file descriptor and move the file pointer ahead -;;; a certain offset for that file. WHENCE can be any of the following: -;;; L_SET Set the file pointer. -;;; L_INCR Increment the file pointer. -;;; L_XTND Extend the file size. (defun unix-lseek (fd offset whence) + "Unix-lseek accepts a file descriptor and moves the file pointer by + OFFSET octets. Whence can be any of the following: + + L_SET Set the file pointer. + L_INCR Increment the file pointer. + L_XTND Extend the file size. + " (declare (type unix-fd fd) - (type (unsigned-byte 32) offset) (type (integer 0 2) whence)) - #!-(and x86 bsd) - (int-syscall ("lseek" int off-t int) fd offset whence) - ;; Need a 64-bit return value type for this. TBD. For now, - ;; don't use this with any 2G+ partitions. - #!+(and x86 bsd) - (int-syscall ("lseek" int unsigned-long unsigned-long int) - fd offset 0 whence)) + (let ((result (alien-funcall (extern-alien "lseek" (function off-t int off-t int)) + fd offset whence))) + (if (minusp result ) + (values nil (get-errno)) + (values result 0)))) ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. ;;; It attempts to read len bytes from the device associated with fd @@ -238,7 +242,7 @@ ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the ;;; length to write. It attempts to write len bytes to the device -;;; associated with fd from the the buffer starting at offset. It returns +;;; associated with fd from the buffer starting at offset. It returns ;;; the actual number of bytes written. (defun unix-write (fd buf offset len) (declare (type unix-fd fd) @@ -294,14 +298,14 @@ ;; a constant. Going the grovel_headers route doesn't seem to be ;; helpful, either, as Solaris doesn't export PATH_MAX from ;; unistd.h. - #!-(or linux openbsd freebsd sunos osf1) (,stub,) - #!+(or linux openbsd freebsd sunos osf1) + #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,) + #!+(or linux openbsd freebsd netbsd sunos osf1 darwin) (or (newcharstar-string (alien-funcall (extern-alien "getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd) 0 + #!+(or linux openbsd freebsd netbsd darwin) 0 #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) @@ -391,12 +395,6 @@ (cast buf c-string) (cast buf (* char)) 256))) -;;; Write the core image of the file described by FD to disk. -(defun unix-fsync (fd) - (declare (type unix-fd fd)) - (void-syscall ("fsync" int) fd)) - - (defun unix-setsid () (int-syscall ("setsid"))) @@ -407,8 +405,8 @@ ;;; information. (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) - (type (unsigned-byte 32) cmd)) - (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) + (type (signed-byte 32) cmd)) + (void-syscall ("ioctl" int int (* char)) fd cmd arg)) ;;;; sys/resource.h @@ -492,25 +490,30 @@ `(if (fixnump ,num) (progn (setf (deref (slot ,fdset 'fds-bits) 0) ,num) - ,@(loop for index upfrom 1 below (/ fd-setsize 32) + ,@(loop for index upfrom 1 below (/ fd-setsize + sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0))) (progn - ,@(loop for index upfrom 0 below (/ fd-setsize 32) + ,@(loop for index upfrom 0 below (/ fd-setsize + sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fdset 'fds-bits) ,index) - (ldb (byte 32 ,(* index 32)) ,num)))))) + (ldb (byte sb!vm:n-machine-word-bits + ,(* index sb!vm:n-machine-word-bits)) + ,num)))))) (defmacro fd-set-to-num (nfds fdset) - `(if (<= ,nfds 32) + `(if (<= ,nfds sb!vm:n-machine-word-bits) (deref (slot ,fdset 'fds-bits) 0) - (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32) + (+ ,@(loop for index upfrom 0 below (/ fd-setsize + sb!vm:n-machine-word-bits) collect `(ash (deref (slot ,fdset 'fds-bits) ,index) - ,(* index 32)))))) + ,(* index sb!vm:n-machine-word-bits)))))) ;;; Examine the sets of descriptors passed as arguments to see whether ;;; they are ready for reading and writing. See the UNIX Programmer's ;;; Manual for more information. (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) - (declare (type (integer 0 #.FD-SETSIZE) nfds) + (declare (type (integer 0 #.fd-setsize) nfds) (type unsigned-byte rdfds wrfds xpfds) (type (or (unsigned-byte 31) null) to-secs) (type (unsigned-byte 31) to-usecs) @@ -557,14 +560,14 @@ ;;; longer than 32 bits anyway, right?":-| (define-alien-type nil (struct wrapped_stat - (st-dev unsigned-long) ; would be dev-t in a real stat + (st-dev unsigned-int) ; would be dev-t in a real stat (st-ino ino-t) (st-mode mode-t) (st-nlink nlink-t) (st-uid uid-t) (st-gid gid-t) - (st-rdev unsigned-long) ; would be dev-t in a real stat - (st-size unsigned-long) ; would be off-t in a real stat + (st-rdev unsigned-int) ; would be dev-t in a real stat + (st-size unsigned-int) ; would be off-t in a real stat (st-blksize unsigned-long) (st-blocks unsigned-long) (st-atime time-t) @@ -652,19 +655,25 @@ (define-alien-routine get-timezone sb!alien:void (when sb!alien:long :in) - (minutes-west sb!alien:int :out) + (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) -(defun unix-get-minutes-west (secs) - (multiple-value-bind (ignore minutes dst) (get-timezone secs) +(defun nanosleep (secs nsecs) + (with-alien ((req (struct timespec)) + (rem (struct timespec))) + (setf (slot req 'tv-sec) secs) + (setf (slot req 'tv-nsec) nsecs) + (loop while (eql sb!unix:eintr + (nth-value 1 + (int-syscall ("nanosleep" (* (struct timespec)) + (* (struct timespec))) + (addr req) (addr rem)))) + do (rotatef req rem)))) + +(defun unix-get-seconds-west (secs) + (multiple-value-bind (ignore seconds dst) (get-timezone secs) (declare (ignore ignore) (ignore dst)) - (values minutes))) - -(defun unix-get-timezone (secs) - (multiple-value-bind (ignore minutes dst) (get-timezone secs) - (declare (ignore ignore) (ignore minutes)) - (values (deref unix-tzname (if dst 1 0))))) - + (values seconds))) ;;;; sys/time.h @@ -685,7 +694,7 @@ (tz (struct timezone))) (syscall* ("gettimeofday" (* (struct timeval)) (* (struct timezone))) - (values T + (values t (slot tv 'tv-sec) (slot tv 'tv-usec) (slot tz 'tz-minuteswest) @@ -701,11 +710,11 @@ (it-interval (struct timeval)) ; timer interval (it-value (struct timeval)))) ; current value -(defconstant ITIMER-REAL 0) -(defconstant ITIMER-VIRTUAL 1) -(defconstant ITIMER-PROF 2) +(defconstant itimer-real 0) +(defconstant itimer-virtual 1) +(defconstant itimer-prof 2) -(defun unix-getitimer(which) +(defun unix-getitimer (which) "Unix-getitimer returns the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). On success, unix-getitimer returns 5 values, @@ -715,12 +724,12 @@ (unsigned-byte 29) (mod 1000000) (unsigned-byte 29) (mod 1000000))) (let ((which (ecase which - (:real ITIMER-REAL) - (:virtual ITIMER-VIRTUAL) - (:profile ITIMER-PROF)))) + (:real itimer-real) + (:virtual itimer-virtual) + (:profile itimer-prof)))) (with-alien ((itv (struct itimerval))) (syscall* ("getitimer" int (* (struct itimerval))) - (values T + (values t (slot (slot itv 'it-interval) 'tv-sec) (slot (slot itv 'it-interval) 'tv-usec) (slot (slot itv 'it-value) 'tv-sec) @@ -743,9 +752,9 @@ (unsigned-byte 29) (mod 1000000) (unsigned-byte 29) (mod 1000000))) (let ((which (ecase which - (:real ITIMER-REAL) - (:virtual ITIMER-VIRTUAL) - (:profile ITIMER-PROF)))) + (:real itimer-real) + (:virtual itimer-virtual) + (:profile itimer-prof)))) (with-alien ((itvn (struct itimerval)) (itvo (struct itimerval))) (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs @@ -753,20 +762,18 @@ (slot (slot itvn 'it-value ) 'tv-sec ) val-secs (slot (slot itvn 'it-value ) 'tv-usec) val-usec) (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) - (values T + (values t (slot (slot itvo 'it-interval) 'tv-sec) (slot (slot itvo 'it-interval) 'tv-usec) (slot (slot itvo 'it-value) 'tv-sec) (slot (slot itvo 'it-value) 'tv-usec)) which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) -(defmacro with-timeout (expires &body body) +(defmacro sb!ext:with-timeout (expires &body body) "Execute the body, interrupting it with a SIGALRM after at least EXPIRES seconds have passed. Uses Unix setitimer(), restoring any previous timer after the body has finished executing" - (let ((saved-seconds (gensym "SAVED-SECONDS")) - (saved-useconds (gensym "SAVED-USECONDS")) - (s (gensym "S")) (u (gensym "U"))) + (with-unique-names (saved-seconds saved-useconds s u) `(let (- ,saved-seconds ,saved-useconds) (multiple-value-setq (- - - ,saved-seconds ,saved-useconds) (unix-getitimer :real)) @@ -782,16 +789,9 @@ previous timer after the body has finished executing" (unix-setitimer :real 0 0 ,s ,u) ,@body) (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds)) - ,@body))))) - + (progn + ,@body)))))) - -(defconstant ENOENT 2) ; Unix error code, "No such file or directory" -(defconstant EINTR 4) ; Unix error code, "Interrupted system call" -(defconstant EIO 5) ; Unix error code, "I/O error" -(defconstant EEXIST 17) ; Unix error code, "File exists" -(defconstant ESPIPE 29) ; Unix error code, "Illegal seek" -(defconstant EWOULDBLOCK 11) ; Unix error code, "Operation would block" ;;; FIXME: Many Unix error code definitions were deleted from the old ;;; CMU CL source code here, but not in the exports of SB-UNIX. I ;;; (WHN) hope that someday I'll figure out an automatic way to detect @@ -799,7 +799,6 @@ previous timer after the body has finished executing" ;;; enough of them all in one place here that they should probably be ;;; removed by hand. - ;;;; support routines for dealing with Unix pathnames (defun unix-file-kind (name &optional check-for-links) @@ -830,12 +829,18 @@ previous timer after the body has finished executing" ;;; 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-string pathname)) + (declare (type simple-base-string pathname)) (aver (not (relative-unix-pathname? pathname))) + ;; KLUDGE: readlink and lstat are unreliable if given symlinks + ;; ending in slashes -- fix the issue here instead of waiting for + ;; libc to change... + (let ((len (length pathname))) + (when (and (plusp len) (eql #\/ (schar pathname (1- len)))) + (setf pathname (subseq pathname 0 (1- len))))) (/noshow "entering UNIX-RESOLVE-LINKS") (loop with previous-pathnames = nil do - (/noshow pathname previous-pathnames) - (let ((link (unix-readlink pathname))) + (/noshow pathname previous-pathnames) + (let ((link (unix-readlink pathname))) (/noshow link) ;; Unlike the old CMU CL code, we handle a broken symlink by ;; returning the link itself. That way, CL:TRUENAME on a @@ -856,7 +861,7 @@ previous timer after the body has finished executing" :from-end t))) (dir (subseq pathname 0 dir-len))) (/noshow dir) - (concatenate 'string dir link)) + (concatenate 'base-string dir link)) link)))) (if (unix-file-kind new-pathname) (setf pathname new-pathname) @@ -872,9 +877,9 @@ previous timer after the body has finished executing" (push pathname previous-pathnames)))) (defun unix-simplify-pathname (src) - (declare (type simple-string src)) + (declare (type simple-base-string src)) (let* ((src-len (length src)) - (dst (make-string src-len)) + (dst (make-string src-len :element-type 'base-char)) (dst-len 0) (dots 0) (last-slash nil)) @@ -948,7 +953,8 @@ previous timer after the body has finished executing" (position #\/ dst :end last-slash :from-end t))) (if prev-prev-slash (setf dst-len (1+ prev-prev-slash)) - (return-from unix-simplify-pathname "./"))))))) + (return-from unix-simplify-pathname + (coerce "./" 'simple-base-string)))))))) (cond ((zerop dst-len) "./") ((= dst-len src-len) @@ -975,32 +981,37 @@ previous timer after the body has finished executing" (defmacro fd-set (offset fd-set) (let ((word (gensym)) (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset 32) + `(multiple-value-bind (,word ,bit) (floor ,offset + sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) - (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) + (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) + (ash 1 ,bit)) (deref (slot ,fd-set 'fds-bits) ,word)))))) ;;; not checked for linux... (defmacro fd-clr (offset fd-set) (let ((word (gensym)) (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset 32) + `(multiple-value-bind (,word ,bit) (floor ,offset + sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) (logand (deref (slot ,fd-set 'fds-bits) ,word) - (sb!kernel:32bit-logical-not - (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) + (sb!kernel:word-logical-not + (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) + (ash 1 ,bit)))))))) ;;; not checked for linux... (defmacro fd-isset (offset fd-set) (let ((word (gensym)) (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset 32) + `(multiple-value-bind (,word ,bit) (floor ,offset + sb!vm:n-machine-word-bits) (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) ;;; not checked for linux... (defmacro fd-zero (fd-set) `(progn - ,@(loop for index upfrom 0 below (/ fd-setsize 32) + ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))