This patch allows "process-fork" to kill all existing threads but the current one when running the child process.
cheers, felix
>From 99c6fdc917e26049be8c00e5ce523ff6a4dd25a7 Mon Sep 17 00:00:00 2001 From: felix <[email protected]> Date: Sun, 28 Oct 2012 12:37:22 +0100 Subject: [PATCH] Added optional argument to process-fork that allows killing all threads in the child process but the current one --- library.scm | 7 ++++++- manual/Unit posix | 7 +++++-- posixunix.scm | 21 +++++++++++++-------- scheduler.scm | 27 +++++++++++++++++++++++++++ 4 files changed, 51 insertions(+), 11 deletions(-) diff --git a/library.scm b/library.scm index 680687f..80b00e6 100644 --- a/library.scm +++ b/library.scm @@ -4382,7 +4382,9 @@ EOF '() ; #12 recipients #f) ) ; #13 unblocked by timeout? -(define ##sys#primordial-thread (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum)) +(define ##sys#primordial-thread + (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum)) + (define ##sys#current-thread ##sys#primordial-thread) (define (##sys#make-mutex id owner) @@ -4404,6 +4406,9 @@ EOF (##sys#setslot ct 1 (lambda () (return (##core#undefined)))) (##sys#schedule) ) ) ) ) +(define (##sys#kill-other-threads) + #f) ; does nothing, will be modified by scheduler.scm + ;;; Interrupt-handling: diff --git a/manual/Unit posix b/manual/Unit posix index 66325a6..170c644 100644 --- a/manual/Unit posix +++ b/manual/Unit posix @@ -649,12 +649,15 @@ of the {{PATH}} environment variable while {{execve(3)}} does not. ==== process-fork -<procedure>(process-fork [THUNK])</procedure> +<procedure>(process-fork [THUNK [KILLOTHERS?]])</procedure> Creates a new child process with the UNIX system call {{fork()}}. Returns either the PID of the child process or 0. If {{THUNK}} is given, then the child process calls it as a procedure -with no arguments and terminates. +with no arguments and terminates. If {{THUNK}} is given and the +optional argument {{KILLOTHERS?}} is true, then kill all other +existing threads in the child process, leaving only the current thread +to run {{THUNK}} and terminate. ==== process-run diff --git a/posixunix.scm b/posixunix.scm index 0277cc5..90fedd5 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -1767,14 +1767,19 @@ EOF ;;; Process handling: (define process-fork - (let ([fork (foreign-lambda int "C_fork")]) - (lambda thunk - (let ([pid (fork)]) - (cond [(fx= -1 pid) (posix-error #:process-error 'process-fork "cannot create child process")] - [(and (pair? thunk) (fx= pid 0)) - ((car thunk)) - ((foreign-lambda void "_exit" int) 0) ] - [else pid] ) ) ) ) ) + (let ((fork (foreign-lambda int "C_fork"))) + (lambda (#!optional thunk killothers) + (let ((pid (fork))) + (when (fx= -1 pid) + (posix-error #:process-error 'process-fork "cannot create child process")) + (if (and thunk (zero? pid)) + ((if killothers + ##sys#kill-other-threads + (lambda (thunk) (thunk))) + (lambda () + (thunk) + ((foreign-lambda void "_exit" int) 0) )) + pid))))) (define process-execute ;; NOTE: We use c-string here instead of scheme-object. diff --git a/scheduler.scm b/scheduler.scm index d3a2620..7ff3d5f 100644 --- a/scheduler.scm +++ b/scheduler.scm @@ -527,3 +527,30 @@ EOF (##sys#remove-from-timeout-list t) (##sys#clear-i/o-state-for-thread! t) (##sys#thread-basic-unblock! t) ) ) + + +;;; Kill all threads in fd-, io- and timeout-lists and assign one thread as the +; new primordial one. Overrides "##sys#kill-all-threads" in library.scm. + +(set! ##sys#kill-other-threads + (let ((exit exit)) + (lambda (thunk) + (let ((primordial ##sys#current-thread)) + (define (suspend t) + (unless (eq? t primordial) + (##sys#setslot t 3 'suspended)) + (##sys#setslot t 11 #f) ; block-object (may be thread) + (##sys#setslot t 12 '())) ; recipients (waiting for join) + (set! ##sys#primordial-thread primordial) + (set! ready-queue-head (list primordial)) + (set! ready-queue-tail ready-queue-head) + (suspend primordial) ; clear block-obj. and recipients + (for-each + (lambda (a) (suspend (cdr a))) + ##sys#timeout-list) + (set! ##sys#timeout-list '()) + (for-each + (lambda (a) (suspend (cdr a))) + ##sys#fd-list) + (thunk) + (exit))))) -- 1.7.0.4
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
