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'.
master
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_NEWPID #x20000000)
(define CLONE_NEWNET #x40000000) (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 ;; 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 ;; low-level system call is wrapped instead. The 'syscall' function is
;; declared in <unistd.h> as a variadic function; in practice, it expects 6 ;; 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 Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes." are shared between the parent and child processes."
(let-values (((ret err) (let-values (((ret err)
(proc syscall-id flags ;; Guile 2.2 runs a finalization thread. 'primitive-fork'
%null-pointer ;child stack ;; takes care of shutting it down before forking, and we
%null-pointer %null-pointer ;ptid & ctid ;; must do the same here. Failing to do that, if the
%null-pointer))) ;unused ;; 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) (if (= ret -1)
(throw 'system-error "clone" "~d: ~A" (throw 'system-error "clone" "~d: ~A"
(list flags (strerror err)) (list flags (strerror err))