1 files changed, 49 insertions, 0 deletions
diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index 16c9328..aa1626e 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -35,3 +35,52 @@ Must not start up any threads."))
      exit
      :on-failure (failed-change
                   "~&Fork connection child failed; stderr was ~%~%~A" err))))
+
+
+;;;; Dumping and then immediately reinvoking Lisp
+
+(defclass init-hooks-connection (fork-connection) ()
+  (:documentation "On SBCL, call POST-FORK using SB-EXT:*INIT-HOOKS*.
+
+The primary purpose of this connection type is to obtain a truly
+single-threaded context for the execution of POST-FORK."))
+
+#+(and sbcl sb-thread)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; UIOP:VERSION< cannot handle Debian-patched SBCL version numbers, so we
+  ;; split it up ourselves.
+  (destructuring-bind (major minor patch . rest)
+      (mapcar (lambda (s) (parse-integer s :junk-allowed t))
+              (split-string (lisp-implementation-version) :separator '(#\.)))
+    (declare (ignore rest))
+    (unless (or (> major 2)
+                (and (= major 2)
+                     (or (> minor 1) (and (= minor 1) (> patch 7)))))
+      (pushnew 'older-sbcl *features*))))
+
+#+sbcl
+(defmethod continue-connection ((connection init-hooks-connection) remaining)
+  (eval-in-reinvoked
+      `(push
+        (lambda ()
+          (handler-bind
+              ((serious-condition
+                 (lambda (c)
+                   (trivial-backtrace:print-backtrace c :output *error-output*)
+                   (uiop:quit 3))))
+            ;; Handle the finaliser thread in older SBCL, before the change in
+            ;; 2.1.8 to call *INIT-HOOKS* before starting system threads.
+            #+consfigurator.connection.fork::older-sbcl
+            (sb-int:with-system-mutex (sb-thread::*make-thread-lock*)
+              (sb-impl::finalizer-thread-stop))
+            (post-fork ,connection)
+            #+consfigurator.connection.fork::older-sbcl
+            (sb-impl::finalizer-thread-start)))
+        sb-ext:*init-hooks*)
+      `(continue-deploy* ,connection ',remaining) (out err exit)
+    (when-let ((lines (lines out)))
+      (inform t lines))
+    (return-exit
+     exit
+     :on-failure (failed-change
+                  "~&Reinvoked Lisp image failed; stderr was ~%~%~A" err))))