new approach to calling fork(2) in remote Lisp images

Drop CAN-PROBABLY-FORK because we now only try to fork(2) in contexts in which
there shouldn't ever be any other threads running, apart from Lisp
implementation finaliser threads and the like.

We no longer need to RESET-DATA-SOURCES before CONTINUE-DEPLOY* because we now
only fork(2) in contexts in which *NO-DATA-SOURCES* is t.

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 70 insertions, 0 deletions

diff --git a/src/util.lisp b/src/util.lisp
index 6de9e71..5524188 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -532,6 +532,47 @@ of this macro."
 Should be called soon after fork(2) in child processes."
   (signal 'in-child-process))
 
+;;; Use only implementation-specific fork, waitpid etc. calls to avoid thread
+;;; woes.  Things like chroot(2) and setuid(2), however, should be okay.
+
+(defun fork ()
+  ;; Normalise any other implementations such that we signal an error if
+  ;; fork(2) returns -1, so caller doesn't have to check for that.
+  #+sbcl (sb-posix:fork))
+
+(defun waitpid (pid options)
+  ;; Normalise any other implementations such that we always return (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 setsid ()
+  #+sbcl (sb-posix:setsid))
+
+(defun umask (mode)
+  #+sbcl (sb-posix:umask mode))
+
+(defmacro forked-progn (child-pid child-form &body parent-forms)
+  (with-gensyms (retval)
+    `(progn
+       #-(or sbcl) (error "Don't know how to safely fork(2) in this Lisp.")
+       (mapc-open-output-streams
+        #'force-output
+        *standard-output* *error-output* *debug-io* *terminal-io*)
+       (let ((,retval (fork)))
+         (if (zerop ,retval)
+             ;; We leave it to the caller to appropriately call CLOSE or
+             ;; CLEAR-INPUT on input streams shared with the parent, because
+             ;; at least SBCL's CLEAR-INPUT clears the OS buffer as well as
+             ;; Lisp's, potentially denying data to both sides of the fork.
+             ,child-form
+             (let ((,child-pid ,retval)) ,@parent-forms))))))
+
 (define-condition skipped-properties () ()
   (:documentation
    "There were failed changes, but instead of aborting, that particular property
@@ -617,3 +658,32 @@ Does not currently establish a PAM session."
              (stream ,file :direction :output :if-exists :supersede)
            (with-standard-io-syntax
              (prin1 ,data stream)))))))
+
+
+;;;; Streams
+
+(defun stream->input-stream (stream)
+  (etypecase stream
+    (synonym-stream (stream->input-stream
+                     (symbol-value (synonym-stream-symbol stream))))
+    (two-way-stream (two-way-stream-input-stream stream))
+    (stream (and (input-stream-p stream) stream))))
+
+(defun mapc-open-input-streams (function &rest streams)
+  (dolist (stream streams streams)
+    (when-let ((input-stream (stream->input-stream stream)))
+      (when (open-stream-p input-stream)
+        (funcall function input-stream)))))
+
+(defun stream->output-stream (stream)
+  (etypecase stream
+    (synonym-stream (stream->output-stream
+                     (symbol-value (synonym-stream-symbol stream))))
+    (two-way-stream (two-way-stream-output-stream stream))
+    (stream (and (output-stream-p stream) stream))))
+
+(defun mapc-open-output-streams (function &rest streams)
+  (dolist (stream streams streams)
+    (when-let ((output-stream (stream->output-stream stream)))
+      (when (open-stream-p output-stream)
+        (funcall function output-stream)))))