X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=e7cd25e10cf50e03ea739f740f9b9c747e12ce9f;hb=4d31006db24db375cdb83a5726d66c524b36689c;hp=be7312215e74339eb1739165c15659397292a847;hpb=16568ba8e4b538858ab752fb2a5ae95e5f39e6dd;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index be73122..e7cd25e 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -27,12 +27,6 @@ (/show0 "unix.lisp 21") -(defmacro def-enum (inc cur &rest names) - (flet ((defform (name) - (prog1 (when name `(defconstant ,name ,cur)) - (setf cur (funcall inc cur 1))))) - `(progn ,@(mapcar #'defform names)))) - ;;; Given a C-level zero-terminated array of C strings, return a ;;; corresponding Lisp-level list of SIMPLE-STRINGs. (defun c-strings->string-list (c-strings) @@ -48,7 +42,7 @@ ;;;; Lisp types used by syscalls (deftype unix-pathname () 'simple-string) -(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) +(deftype unix-fd () `(integer 0 ,sb!xc:most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) (deftype unix-pid () '(unsigned-byte 32)) @@ -62,6 +56,10 @@ ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other ;;; macros in this file, are only used in this file, and could be ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. +;;; +;;; SB-EXECUTABLE, at least, uses one of these macros; other libraries +;;; and programs have been known to use them as well. Perhaps they +;;; should live in SB-SYS or even SB-EXT? (defmacro syscall ((name &rest arg-types) success-form &rest args) `(locally @@ -84,11 +82,6 @@ (error "Syscall ~A failed: ~A" ,name (strerror)) ,success-form)))) -(/show0 "unix.lisp 109") - -(defmacro void-syscall ((name &rest arg-types) &rest args) - `(syscall (,name ,@arg-types) (values t 0) ,@args)) - (defmacro int-syscall ((name &rest arg-types) &rest args) `(syscall (,name ,@arg-types) (values result 0) ,@args)) @@ -105,6 +98,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (return (values ,value ,errno)))) ,@body)) +(defmacro void-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values t 0) ,@args)) + #!+win32 (progn (defconstant espipe 29)) @@ -114,7 +110,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-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." +corresponds to NAME, or NIL if there is none." (name c-string)) ;;; from stdio.h @@ -180,16 +176,22 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; stdlib.h ;;; There are good reasons to implement some OPEN options with an -;;; mkstemp(3) followed by a fchmod(2) followed by a rename(2), but we -;;; don't do that yet. Instead, this function is used only to make a -;;; temporary file for RUN-PROGRAM. sb_mkstemp() is a wrapper that -;;; lives in src/runtime/wrap.c. -(defun unix-mkstemp (template-string) - (let ((template-buffer (string-to-octets template-string))) +;;; mkstemp(3)-like routine, but we don't do that yet. Instead, this +;;; function is used only to make a temporary file for RUN-PROGRAM. +;;; sb_mkstemp() is a wrapper that lives in src/runtime/wrap.c. Since +;;; SUSv3 mkstemp() doesn't specify the mode of the created file and +;;; since we have to implement most of this ourselves for Windows +;;; anyway, it seems worthwhile to depart from the mkstemp() +;;; specification by taking a mode to use when creating the new file. +(defun sb-mkstemp (template-string mode) + (declare (type string template-string) + (type unix-file-mode mode)) + (let ((template-buffer (string-to-octets template-string :null-terminate t))) (with-pinned-objects (template-buffer) (let ((fd (alien-funcall (extern-alien "sb_mkstemp" - (function int (* char))) - (vector-sap template-buffer)))) + (function int (* char) int)) + (vector-sap template-buffer) + mode))) (if (minusp fd) (values nil (get-errno)) (values fd (octets-to-string template-buffer))))))) @@ -200,12 +202,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; 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 +#!-(or win32 openbsd netbsd) (define-alien-type nil (struct timeval (tv-sec time-t) ; seconds (tv-usec suseconds-t))) ; and microseconds +;; The above definition doesn't work on 64-bit OpenBSD platforms. +;; Both tv_sec and tv_usec are declared as long instead of time_t, and +;; time_t is a typedef for int. +#!+(or openbsd netbsd) +(define-alien-type nil + (struct timeval + (tv-sec long) ; seconds + (tv-usec long))) ; and microseconds + #!+win32 (define-alien-type nil (struct timeval @@ -389,15 +400,15 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; comma not inside a backquote. This error has absolutely nothing ;; to do with the actual meaning of the error (and little to do with ;; its location, either). - #!-(or linux openbsd freebsd netbsd sunos osf1 darwin win32) (,stub,) - #!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32) + #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (,stub,) + #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (or (newcharstar-string (alien-funcall (extern-alien "getcwd" (function (* char) (* char) size-t)) nil #!+(or linux openbsd freebsd netbsd darwin win32) 0 - #!+(or sunos osf1) 1025)) + #!+(or sunos osf1 hpux) 1025)) (simple-perror "getcwd"))) ;;; Return the Unix current directory as a SIMPLE-STRING terminated @@ -761,27 +772,26 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (syscall ("fstat_wrapper" int (* (struct wrapped_stat))) (%extract-stat-results (addr buf)) fd (addr buf)))) - -;;; RUN-PROGRAM creates temporary files with mkstemp, but SUSv3 -;;; doesn't specify the mode of a newly created file under mkstemp, -;;; and C libraries may vary, so we fix the mode ourselves. -;;; Eventually some OPEN actions should probably be implemented with -;;; mkstemp(3)/chmod(2)/rename(2) as well. -#!-win32 -(defun unix-chmod (path mode) - (declare (type unix-pathname path) - (type unix-file-mode mode)) - (void-syscall ("chmod" c-string int) path mode)) ;;;; time.h ;; the POSIX.4 structure for a time value. This is like a "struct ;; timeval" but has nanoseconds instead of microseconds. +#!-(or openbsd netbsd) (define-alien-type nil (struct timespec (tv-sec long) ; seconds (tv-nsec long))) ; nanoseconds +;; Just as with struct timeval, 64-bit OpenBSD has problems with the +;; above definition. tv_sec is declared as time_t instead of long, +;; and time_t is a typedef for int. +#!+(or openbsd netbsd) +(define-alien-type nil + (struct timespec + (tv-sec time-t) ; seconds + (tv-nsec long))) ; nanoseconds + ;; used by other time functions (define-alien-type nil (struct tm @@ -798,7 +808,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (tm-zone c-string))) ; Timezone abbreviation. (define-alien-routine get-timezone sb!alien:void - (when sb!alien:long :in) + (when time-t :in) (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) @@ -828,39 +838,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (struct timezone (tz-minuteswest int) ; minutes west of Greenwich (tz-dsttime int))) ; type of dst correction - -;;; If it works, UNIX-GETTIMEOFDAY returns 5 values: T, the seconds -;;; and microseconds of the current time of day, the timezone (in -;;; minutes west of Greenwich), and a daylight-savings flag. If it -;;; 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)) - (* (struct timezone))) - (values t - (slot tv 'tv-sec) - (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) - (addr tv) - (addr tz)))) ;; Type of the second argument to `getitimer' and @@ -939,24 +916,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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) - #!+sb-doc - "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (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) - (ignore dev ino)) - (when res - (let ((kind (logand mode s-ifmt))) - (cond ((eql kind s-ifdir) :directory) - ((eql kind s-ifreg) :file) - #!-win32 - ((eql kind s-iflnk) :link) - (t :special)))))) - (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) @@ -964,12 +923,40 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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) (unix-gettimeofday) - (declare (ignore _) (type (unsigned-byte 32) sec usec)) + (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 @@ -1001,9 +988,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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 + ;; 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)) @@ -1032,6 +1031,60 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." micro-seconds-per-internal-time-unit)))) result)))) +;;; 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))) + +;;;; 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)) + ;;;; A magic constant for wait3(). ;;;; ;;;; FIXME: This used to be defined in run-program.lisp as @@ -1049,8 +1102,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; not checked for linux... (defmacro fd-set (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (with-unique-names (word bit) `(multiple-value-bind (,word ,bit) (floor ,offset sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) @@ -1060,8 +1112,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; not checked for linux... (defmacro fd-clr (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (with-unique-names (word bit) `(multiple-value-bind (,word ,bit) (floor ,offset sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) @@ -1072,8 +1123,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; not checked for linux... (defmacro fd-isset (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (with-unique-names (word bit) `(multiple-value-bind (,word ,bit) (floor ,offset sb!vm:n-machine-word-bits) (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))