X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=c5e6ee141952d888e19faec42361c695adeca257;hb=de26f53dce412ab8ae84313d4937045498910d46;hp=74f98bef6959eb78ec7ae2912ebd34929eeb6fd6;hpb=074ba0606c687dbca4afc99e8e72e6f1a4486d24;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 74f98be..c5e6ee1 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") @@ -87,6 +91,19 @@ (defmacro int-syscall ((name &rest arg-types) &rest args) `(syscall (,name ,@arg-types) (values result 0) ,@args)) + +(defmacro with-restarted-syscall ((&optional (value (gensym)) + (errno (gensym))) + syscall-form &rest body) + #!+sb-doc + "Evaluate BODY with VALUE and ERRNO bound to the return values of +SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." + `(let (,value ,errno) + (loop (multiple-value-setq (,value ,errno) + ,syscall-form) + (unless (eql ,errno sb!unix:eintr) + (return (values ,value ,errno)))) + ,@body)) ;;;; hacking the Unix environment @@ -119,7 +136,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") @@ -237,7 +255,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) @@ -390,12 +408,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"))) @@ -491,25 +503,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) @@ -654,6 +671,18 @@ (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) +(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)) @@ -678,7 +707,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) @@ -694,11 +723,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, @@ -708,12 +737,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) @@ -736,9 +765,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 @@ -746,7 +775,7 @@ (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) @@ -813,12 +842,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 @@ -839,7 +874,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) @@ -855,9 +890,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)) @@ -931,7 +966,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) @@ -958,32 +994,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))))