X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=45c0ccce2248b1b54cbd588fe7efa7bb1dcfebb1;hb=bb756e3d4b19c30d4a9cd4250b606c5969613ad9;hp=0119d6ca79db464e0dbf01bd850a20674f5bf482;hpb=2b596efa9a6b08a22bbdcdf88198c5d2af1d0335;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 0119d6c..45c0ccc 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -138,6 +138,17 @@ (defvar *active-processes* nil "List of process structures for all active processes.") +(defvar *active-processes-lock* + (sb-thread:make-mutex :name "Lock for active processes.")) + +;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a +;;; mutex is needed. More importantly the sigchld signal handler also +;;; accesses it, that's why we need without-interrupts. +(defmacro with-active-processes-lock (() &body body) + `(without-interrupts + (sb-thread:with-mutex (*active-processes-lock*) + ,@body))) + (defstruct (process (:copier nil)) pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED @@ -245,7 +256,7 @@ (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE. (frob (process-output proc) nil) (frob (process-error proc) nil)) - (sb-sys:without-interrupts + (with-active-processes-lock () (setf *active-processes* (delete proc *active-processes*))) proc) @@ -260,17 +271,18 @@ (wait3 t t) (unless pid (return)) - (let ((proc (find pid *active-processes* :key #'process-pid))) - (when proc - (setf (process-%status proc) what) - (setf (process-exit-code proc) code) - (setf (process-core-dumped proc) core) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - (when (position what #(:exited :signaled)) - (sb-sys:without-interrupts - (setf *active-processes* - (delete proc *active-processes*))))))))) + (let ((proc (with-active-processes-lock () + (find pid *active-processes* :key #'process-pid)))) + (when proc + (setf (process-%status proc) what) + (setf (process-exit-code proc) code) + (setf (process-core-dumped proc) core) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + (when (position what #(:exited :signaled)) + (with-active-processes-lock () + (setf *active-processes* + (delete proc *active-processes*))))))))) ;;;; RUN-PROGRAM and close friends @@ -289,12 +301,12 @@ (defun find-a-pty () (dolist (char '(#\p #\q)) (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) + (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) (master-fd (sb-unix:unix-open master-name sb-unix:o_rdwr #o666))) (when master-fd - (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) (slave-fd (sb-unix:unix-open slave-name sb-unix:o_rdwr #o666))) @@ -320,7 +332,8 @@ (push new-fd *close-on-error*) (copy-descriptor-to-stream new-fd pty cookie))) (values name - (sb-sys:make-fd-stream master :input t :output t))))) + (sb-sys:make-fd-stream master :input t :output t + :dual-channel-p t))))) (defmacro round-bytes-to-words (n) `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) @@ -331,7 +344,8 @@ (let ((string-bytes 0) ;; We need an extra for the null, and an extra 'cause exect ;; clobbers argv[-1]. - (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2)))) + (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits) + (+ (length string-list) 2)))) (declare (fixnum string-bytes vec-bytes)) (dolist (s string-list) (enforce-type s simple-string) @@ -340,25 +354,28 @@ (let* ((total-bytes (+ string-bytes vec-bytes)) (vec-sap (sb-sys:allocate-system-memory total-bytes)) (string-sap (sap+ vec-sap vec-bytes)) - (i #-alpha 4 #+alpha 8)) + (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))) (declare (type (and unsigned-byte fixnum) total-bytes i) (type sb-sys:system-area-pointer vec-sap string-sap)) (dolist (s string-list) (declare (simple-string s)) (let ((n (length s))) ;; Blast the string into place. - (sb-kernel:copy-to-system-area (the simple-string s) - (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - string-sap 0 - (* (1+ n) sb-vm:n-byte-bits)) + (sb-kernel:copy-ub8-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) + 0 + string-sap 0 + (1+ n)) ;; Blast the pointer to the string into place. (setf (sap-ref-sap vec-sap i) string-sap) (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i #-alpha 4 #+alpha 8))) + (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))) ;; Blast in the last null pointer. (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes)))) + (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits + sb-vm::n-byte-bits)) + total-bytes)))) (defmacro with-c-strvec ((var str-list) &body body) (with-unique-names (sap size) @@ -382,6 +399,7 @@ ;;; Is UNIX-FILENAME the name of a file that we can execute? (defun unix-filename-is-executable-p (unix-filename) (declare (type simple-string unix-filename)) + (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) (sb-unix:unix-access unix-filename sb-unix:x_ok)))) @@ -579,7 +597,7 @@ ;; Make sure we are not notified about the child ;; death before we have installed the PROCESS ;; structure in *ACTIVE-PROCESSES*. - (sb-sys:without-interrupts + (with-active-processes-lock () (with-c-strvec (args-vec simple-args) (with-c-strvec (environment-vec environment) (let ((child-pid @@ -614,7 +632,7 @@ ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) - (let ((string (make-string 256)) + (let ((string (make-string 256 :element-type 'base-char)) handler) (setf handler (sb-sys:add-fd-handler @@ -660,11 +678,10 @@ ~2I~_~A~:>" (strerror errno))) (t - (sb-kernel:copy-from-system-area + (sb-kernel:copy-ub8-from-system-area (alien-sap buf) 0 - string (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - (* count sb-vm:n-byte-bits)) + string 0 + count) (write-string string stream :end count))))))))))) @@ -683,7 +700,7 @@ ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open "/dev/null" + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) (case direction (:input sb-unix:o_rdonly) (:output sb-unix:o_wronly) @@ -735,7 +752,7 @@ (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) (fd (sb-unix:unix-open name (logior sb-unix:o_rdwr sb-unix:o_creat @@ -750,7 +767,16 @@ (read-line object nil nil) (unless line (return)) - (sb-unix:unix-write fd line 0 (length line)) + (sb-unix:unix-write + fd + ;; FIXME: this really should be + ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). + ;; RUN-PROGRAM should take an + ;; external-format argument, which should + ;; be passed down to here. Something + ;; similar should happen on :OUTPUT, too. + (map '(vector (unsigned-byte 8)) #'char-code line) + 0 (length line)) (if no-cr (return) (sb-unix:unix-write fd newline 0 1)))))