syscalls: Adjust 'clone' to Guile 2.2.

Before that, something like:

  (call-with-container
    (lambda ()
      (match (primitive-fork)
        …)))

would hang in 'primitive-fork' as the child process (the one started in
the container) would try to pthread_join the finalization thread in
'stop_finalization_thread' in libguile, not knowing that this thread is
nonexistent.

* guix/build/syscalls.scm (%set-automatic-finalization-enabled?!): New
procedure.
(without-automatic-finalization): New macro.
(clone): Wrap PROC call in 'without-automatic-finalization'.
This commit is contained in:
Ludovic Courtès 2017-03-15 13:41:18 +01:00
parent 81a0f1cdf1
commit 70dfdd501a
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 41 additions and 4 deletions

View File

@ -656,6 +656,36 @@ mounted at FILE."
(define CLONE_NEWPID #x20000000)
(define CLONE_NEWNET #x40000000)
(cond-expand
(guile-2.2
(define %set-automatic-finalization-enabled?!
(let ((proc (pointer->procedure int
(dynamic-func
"scm_set_automatic_finalization_enabled"
(dynamic-link))
(list int))))
(lambda (enabled?)
"Switch on or off automatic finalization in a separate thread.
Turning finalization off shuts down the finalization thread as a side effect."
(->bool (proc (if enabled? 1 0))))))
(define-syntax-rule (without-automatic-finalization exp)
"Turn off automatic finalization within the dynamic extent of EXP."
(let ((enabled? #t))
(dynamic-wind
(lambda ()
(set! enabled? (%set-automatic-finalization-enabled?! #f)))
(lambda ()
exp)
(lambda ()
(%set-automatic-finalization-enabled?! enabled?))))))
(else
(define-syntax-rule (without-automatic-finalization exp)
;; Nothing to do here: Guile 2.0 does not have a separate finalization
;; thread.
exp)))
;; The libc interface to sys_clone is not useful for Scheme programs, so the
;; low-level system call is wrapped instead. The 'syscall' function is
;; declared in <unistd.h> as a variadic function; in practice, it expects 6
@ -678,10 +708,17 @@ mounted at FILE."
Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes."
(let-values (((ret err)
(proc syscall-id flags
%null-pointer ;child stack
%null-pointer %null-pointer ;ptid & ctid
%null-pointer))) ;unused
;; Guile 2.2 runs a finalization thread. 'primitive-fork'
;; takes care of shutting it down before forking, and we
;; must do the same here. Failing to do that, if the
;; child process calls 'primitive-fork', it will hang
;; while trying to pthread_join the finalization thread
;; since that thread does not exist.
(without-automatic-finalization
(proc syscall-id flags
%null-pointer ;child stack
%null-pointer %null-pointer ;ptid & ctid
%null-pointer)))) ;unused
(if (= ret -1)
(throw 'system-error "clone" "~d: ~A"
(list flags (strerror err))