mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-22 20:42:03 -08:00
Code Issues Projects Releases Packages Wiki Activity

run-program: fix loop in pipe-stream

Browse source 
When we have called something like this

    (ext:run-program "true" nil :wait nil :output *standard-output*)

pipe-stream were running in a loop until someone has called
external-process-wait (or external-process-status). This was a hogging the
processor without a reason. Right now unless some other wait is already called
checks for the process status (and magically removes zombies).

Also always call sleep (not thread-yield), because this loop eats a lot of cpu
otherwise.
This commit is contained in:
Daniel Kochmanski 2018-04-06 15:56:15 +02:00
parent 59f74fc4be
commit 3fd005d8df
1 changed files with 16 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/lsp/process.lsp
View file

@ -7,8 +7,17 @@
(in-package "EXT")
(defmacro with-process-lock ((process) &body body)
#+threads `(mp:with-lock ((external-process-%lock process)) ,@body)
(defmacro with-process-lock ((process &optional (wait t)) &body body)
#+threads
(ext:with-unique-names (lock wait-p)
`(let ((,lock (external-process-%lock ,process))
(,wait-p ,wait))
(mp:without-interrupts
(unwind-protect (mp::with-restored-interrupts
(when (mp:get-lock ,lock ,wait-p)
(locally ,@body)))
(when (mp:holding-lock-p ,lock)
(mp:giveup-lock ,lock))))))
#-threads `(progn ,@body))
(defstruct (external-process (:constructor make-external-process ()))
@ -36,10 +45,11 @@
;;; running :: (values (member :stopped :resumed :running) code pid)
;;; ---------------------------------------------------------------------
(defun external-process-wait (process &optional wait)
(with-process-lock (process)
(with-process-lock (process wait)
(let ((pid (external-process-pid process)))
(when pid
(multiple-value-bind (status code pid) (si:waitpid pid wait)
(declare (ignore pid))
(ecase status
((:exited :signaled :abort :error)
(setf (external-process-pid process) nil
@ -261,9 +271,8 @@
;; note we don't use serve-event here because process input may be a virtual
;; stream and `select' won't catch this stream change.
(si:until (or (null pairs)
(member #-threads (external-process-wait process nil)
#+threads (external-process-%status process)
'(:exited :siognaled :abort :error)))
(member (external-process-wait process nil)
'(:exited :signaled :abort :error)))
#1=(dolist (pair pairs)
(destructuring-bind (input . output) pair
(when (or (null (open-stream-p output))
@ -274,7 +283,6 @@
;; remove from the list exhausted streams
(when to-remove
(setf pairs (set-difference pairs to-remove)))
#+threads (mp:process-yield)
#-threads (sleep 0.001))
(sleep 0.001))
;; something may still be in pipes after child termination
#1#)