fringe3 files changed, 74 insertions(+), 54 deletions(-)
gnu/build/linux-container.scm | 2 +-
guix/build/syscalls.scm | 61 ++++++++++++++++++++++++++++++++++++++++++-------------------
tests/syscalls.scm | 65 +++++++++++++++++++++++++++++++----------------------------------
fringemodified gnu/build/linux-container.scm
fringe@@ -264,7 +264,7 @@ (define* (run-container root mounts namespaces host-uids thunk
(match (socketpair PF_UNIX (logior SOCK_CLOEXEC SOCK_STREAM) 0)
((child . parent)
(let ((flags (namespaces->bit-mask namespaces)))
- (match (clone flags)
+ (match (safe-clone flags)
(0
(call-with-clean-exit
(lambda ()
fringemodified guix/build/syscalls.scm
fringe@@ -150,6 +150,7 @@ (define-module (guix build syscalls)
CLONE_THREAD
CLONE_VM
clone
+ safe-clone
unshare
setns
get-user-ns
fringe@@ -1184,7 +1185,8 @@ (define-syntax-rule (without-automatic-finalization body ...)
(define-syntax-rule (without-garbage-collection body ...)
"Turn off garbage collection within the dynamic extent of BODY. This is useful
-to ensure there are no garbage collection threads."
+to avoid the creation new garbage collection thread. Note that pre-existing
+GC marker threads are only disabled, not terminated."
(dynamic-wind
(lambda ()
(gc-disable))
fringe@@ -1194,15 +1196,22 @@ (define-syntax-rule (without-garbage-collection body ...)
(gc-enable))))
(define-syntax-rule (without-threads body ...)
- "Ensure there are no Guile or garbage collection threads."
- ;; Guile can spawn the following threads: the finalization thread, the
- ;; signal thread, or the GC marker threads.
-
- ;; TODO: Assert there are no signal threads, or better, pause and restore
- ;; them later?
+ "Ensure the Guile finalizer thread is stopped and that garbage collection does
+not run. Note that pre-existing GC marker threads are only disabled, not
+terminated. This also leaves the signal handling thread to be disabled by
+another means, since there is no Guile API to do so."
+ ;; Note: the three kind of threads that Guile can spawn are the finalization
+ ;; thread, the signal thread, or the GC marker threads.
(without-automatic-finalization
(without-garbage-collection body ...)))
+(define (ensure-signal-delivery-thread)
+ "Ensure the signal delivery thread is spawned and its state set
+ to 'RUNNNING'."
+ (match (sigaction SIGUSR1)
+ ((handler . flags)
+ (sigaction SIGUSR1 handler flags))))
+
;; 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
fringe@@ -1245,15 +1254,33 @@ (define clone
(list err))
ret)))))
+(define (safe-clone flags child parent)
+ "This is a raw clone syscall wrapper that ensures no Guile thread will be
+spawned during execution of the child. `clone' is called with FLAGS. CHILD
+is a thunk to run in the child process. PARENT is procedure that accepts the
+child PID as argument. This is useful in many contexts, such as when calling
+`unshare' or async-unsafe procedures in the child when the parent process
+memory (CLONE_VM) or threads (CLONE_THREAD) are shared with it."
+ ;; TODO: Contribute `clone' to Guile, and handle these complications there,
+ ;; similarly to how it's handled for scm_fork in posix.c.
+
+ ;; XXX: This is a hack: by starting the signal delivery thread in the
+ ;; parent, it's state will be known as RUNNING, and the child won't attempt
+ ;; to start it itself.
+ (ensure-signal-delivery-thread)
+ (match (clone flags)
+ (0 (without-threads (child)))
+ (pid (parent pid))))
+
(define unshare
(let ((proc (syscall->procedure int "unshare" (list int))))
(lambda (flags)
"Disassociate the current process from parts of its execution context
according to FLAGS, which must be a logical or of CLONE_* constants. When
CLONE_NEWUSER, CLONE_SIGHAND, CLONE_THREAD or CLONE_VM are specified, this
-wrapper attempts to ensure be single-threaded operation, by disabling
-finalization and garbage collection. If this requirement is not met, this
-produces a warning and throws to 'system-error' with EINVAL."
+wrapper verifies the caller's environment is single-threaded. If this
+requirement is not met, this produces a warning and throws to 'system-error'
+with EINVAL."
(let* ((require-single-thread? (logand (logior CLONE_NEWUSER
CLONE_SIGHAND
CLONE_THREAD
fringe@@ -1263,15 +1290,11 @@ (define unshare
(when (and require-single-thread?
(not (>= 1 (length (all-threads)))))
(format (current-warning-port)
- (string-append
- "warning: unshare single-thread "
- "requirement violated~%"))))))
- (let-values (((ret err)
- (if require-single-thread?
- (without-threads
- (warn/maybe)
- (proc flags))
- (proc flags))))
+ "warning: unshare single-thread \
+requirement violated~%")))))
+ (let-values (((ret err) (begin
+ (warn/maybe)
+ (proc flags))))
(unless (zero? ret)
(throw 'system-error "unshare" "~a: ~A"
(list flags (strerror err))
fringemodified tests/syscalls.scm
fringe@@ -28,6 +28,7 @@
(srfi srfi-64)
(srfi srfi-71)
(system foreign)
+ (ice-9 format)
((ice-9 ftw) #:select (scandir))
(ice-9 match)
(ice-9 threads))
fringe@@ -159,44 +160,40 @@ (define perform-container-tests?
(lambda args
(system-error-errno args))))
-(unless perform-container-tests?
- (test-skip 1))
-(test-equal "unshare handles GC threads"
- 0
- (match (clone (logior CLONE_NEWUSER SIGCHLD))
- (0
- (gc)
- (let ((status (catch 'system-error
- (lambda ()
- (unshare CLONE_THREAD)
- 0)
- (lambda args
- (system-error-errno args)))))
- (primitive-exit status)))
- (pid
- (match (waitpid pid)
+(define child-thunk
+ (lambda ()
+ ;; Spawn a background thread to ensure multi-threaded state.
+ (call-with-new-thread
+ (lambda ()
+ (sleep 1))) ;keep it alive for long enough
+ (let ((status (catch 'system-error
+ (lambda ()
+ (unshare CLONE_THREAD)
+ 0) ;no error
+ (lambda args
+ (system-error-errno args)))))
+ (primitive-exit status))))
+
+(define parent-proc
+ (lambda (pid)
+ (match (waitpid pid)
((_ . status)
- (status:exit-val status))))))
+ (status:exit-val status)))))
-(test-equal "unshare fails in multi-threaded scenario"
+(unless perform-container-tests?
+ (test-skip 1))
+(test-equal "clone and unshare triggers EINVAL"
EINVAL
(match (clone (logior CLONE_NEWUSER SIGCHLD))
- (0
- ;; Spawn a background thread to ensure multi-threaded state.
- (call-with-new-thread
- (lambda ()
- (sleep 1))) ;keep it alive for long enough
- (let ((status (catch 'system-error
- (lambda ()
- (unshare CLONE_THREAD)
- 0) ;no error
- (lambda args
- (system-error-errno args)))))
- (primitive-exit status)))
- (pid
- (match (waitpid pid)
- ((_ . status)
- (status:exit-val status))))))
+ (0 (child-thunk))
+ (pid (parent-proc pid))))
+
+(unless perform-container-tests?
+ (test-skip 1))
+(test-equal "safe-clone and unshare succeeds"
+ 0
+ (safe-clone (logior CLONE_NEWUSER SIGCHLD)
+ child-thunk parent-proc))
(unless perform-container-tests?
(test-skip 1))
[back]