[bug#67824] [PATCH core-updates v2 8/9] build-system/gnu: Turn PID 1 into an “init”-style process by default.

["Ludovic Courtès" <ludo@gnu.org>]

Fixes <https://issues.guix.gnu.org/30948>.

* guix/build/gnu-build-system.scm (separate-from-pid1): New procedure.
(%standard-phases): Add it.
* guix/build-system/gnu.scm (gnu-build): Add #:separate-from-pid1? and
honor it.
(gnu-cross-build): Likewise.

Reported-by: Carlo Zancanaro <carlo@zancanaro.id.au>
Change-Id: I6f3bc8d8186d1a571f983a38d5e3fd178ffa2678
---
 guix/build-system/gnu.scm       |  4 ++++
 guix/build/gnu-build-system.scm | 39 ++++++++++++++++++++++++++++++++-
 2 files changed, 42 insertions(+), 1 deletion(-)

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 0f886fe21d..6a89bcc0d8 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -362,6 +362,7 @@ (define* (gnu-build name inputs
                     (license-file-regexp %license-file-regexp)
                     (phases '%standard-phases)
                     (locale "C.UTF-8")
+                    (separate-from-pid1? #t)
                     (system (%current-system))
                     (build (nix-system->gnu-triplet system))
                     (imported-modules %default-gnu-imported-modules)
@@ -404,6 +405,7 @@ (define* (gnu-build name inputs
                                           (sexp->gexp phases)
                                           phases)
                            #:locale #$locale
+                           #:separate-from-pid1? #$separate-from-pid1?
                            #:bootstrap-scripts #$bootstrap-scripts
                            #:configure-flags #$(if (pair? configure-flags)
                                                    (sexp->gexp configure-flags)
@@ -502,6 +504,7 @@ (define* (gnu-cross-build name
                           (license-file-regexp %license-file-regexp)
                           (phases '%standard-phases)
                           (locale "C.UTF-8")
+                          (separate-from-pid1? #t)
                           (system (%current-system))
                           (build (nix-system->gnu-triplet system))
                           (imported-modules %default-gnu-imported-modules)
@@ -547,6 +550,7 @@ (define* (gnu-cross-build name
                                   (sexp->gexp phases)
                                   phases)
                    #:locale #$locale
+                   #:separate-from-pid1? #$separate-from-pid1?
                    #:bootstrap-scripts #$bootstrap-scripts
                    #:configure-flags #$configure-flags
                    #:make-flags #$make-flags
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 39707e7ace..51b8f9acbf 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -72,6 +72,42 @@ (define (first-subdirectory directory)
     ((first . _) first)
     (_ #f)))
 
+(define* (separate-from-pid1 #:key (separate-from-pid1? #t)
+                             #:allow-other-keys)
+  "When running as PID 1 and SEPARATE-FROM-PID1? is true, run build phases as
+a child process; PID 1 then becomes responsible for reaping child processes."
+  (if separate-from-pid1?
+      (if (= 1 (getpid))
+          (dynamic-wind
+            (const #t)
+            (lambda ()
+              (match (primitive-fork)
+                (0 #t)
+                (builder-pid
+                 (format (current-error-port)
+                         "build process now running as PID ~a~%"
+                         builder-pid)
+                 (let loop ()
+                   ;; Running as PID 1 so take responsibility for reaping
+                   ;; child processes.
+                   (match (waitpid WAIT_ANY)
+                     ((pid . status)
+                      (if (= pid builder-pid)
+                          (if (zero? status)
+                              (primitive-exit 0)
+                              (begin
+                                (format (current-error-port)
+                                        "build process ~a exited with status ~a~%"
+                                        pid status)
+                                (primitive-exit 1)))
+                          (loop))))))))
+            (const #t))
+          (format (current-error-port) "not running as PID 1 (PID: ~a)~%"
+                  (getpid)))
+      (format (current-error-port)
+              "build process running as PID ~a; not forking~%"
+              (getpid))))
+
 (define* (set-paths #:key target inputs native-inputs
                     (search-paths '()) (native-search-paths '())
                     #:allow-other-keys)
@@ -872,7 +908,8 @@ (define %standard-phases
   ;; Standard build phases, as a list of symbol/procedure pairs.
   (let-syntax ((phases (syntax-rules ()
                          ((_ p ...) `((p . ,p) ...)))))
-    (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
+    (phases separate-from-pid1
+            set-SOURCE-DATE-EPOCH set-paths install-locale unpack
             bootstrap
             patch-usr-bin-file
             patch-source-shebangs configure patch-generated-file-shebangs
-- 
2.41.0