ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

syscalls: Adjust 'clone' to Guile 2.2.

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

45
guix/build/syscalls.scm
View file

@ -656,6 +656,36 @@ (define CLONE_NEWUSER #x10000000)
(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 @@ (define clone
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))