From fadfbfc99f0409eb9899c7494d17e15ff596542d Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 1 Apr 2021 15:41:26 -0700 Subject: propagate :NO-CHANGE out of fork subdeployments Signed-off-by: Sean Whitton --- src/connection/fork.lisp | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) (limited to 'src/connection/fork.lisp') diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp index be392cd..989668c 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -29,6 +29,12 @@ ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does #+sbcl (sb-posix:waitpid pid options)) +(defun wifexited (status) + #+sbcl (sb-posix:wifexited status)) + +(defun wexitstatus (status) + #+sbcl (sb-posix:wexitstatus status)) + (defun can-probably-fork () "Return nil if we can detect other running threads, and the Lisp implementation is known not to support forking when there are other threads. @@ -78,15 +84,20 @@ for example, such that we don't see it." ;; (establish-connection :local)) here, but we need to kill ;; off the child afterwards, rather than returning to the ;; child's REPL or whatever else. - (continue-deploy* remaining) - (uiop:quit 0))) + (uiop:quit + (if (eql :no-change (continue-deploy* remaining)) + 0 + 1)))) (t - (multiple-value-bind (_ status) (waitpid child 0) - (declare (ignore _)) - (unless (zerop status) - ;; TODO instead of parsing the status ourselves here, maybe we - ;; can call the various C macros for parsing the status in wait(2) - (error - "Fork connection child failed, status #x~(~4,'0X~)" status))) - ;; return nil to %CONSFIGURE - nil)))) + (multiple-value-bind (pid status) (waitpid child 0) + (declare (ignore pid)) + (let ((exited (wifexited status))) + (unless exited + (error + "Fork connection child did not exit normally, status #x~(~4,'0X~)" + status)) + (let ((exit-status (wexitstatus status))) + (unless (< exit-status 2) + (error + "Fork connection child failed, exit code ~D" exit-status)) + (values nil (if (zerop status) :no-change nil))))))))) -- cgit v1.2.3