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:
		
							parent
							
								
									81a0f1cdf1
								
							
						
					
					
						commit
						70dfdd501a
					
				
					 1 changed files with 41 additions and 4 deletions
				
			
		| 
						 | 
					@ -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)
 | 
				
			||||||
 | 
					                    ;; 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
 | 
					                     (proc syscall-id flags
 | 
				
			||||||
                           %null-pointer              ;child stack
 | 
					                           %null-pointer              ;child stack
 | 
				
			||||||
                           %null-pointer %null-pointer ;ptid & ctid
 | 
					                           %null-pointer %null-pointer ;ptid & ctid
 | 
				
			||||||
                          %null-pointer)))                  ;unused
 | 
					                           %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))
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue