~ chicken-core (chicken-5) 47b5be71353305425a419831ff2a5682a5c39df1

commit 47b5be71353305425a419831ff2a5682a5c39df1
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Oct 28 12:37:22 2012 +0100
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Mon Oct 29 21:26:41 2012 +0100

    Added optional argument to process-fork that allows killing all threads in the child process but the current one
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/library.scm b/library.scm
index 680687fb..ffd01914 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 thunk)
+  (thunk))	     ; does nothing, will be modified by scheduler.scm
+
 
 ;;; Interrupt-handling:
 
diff --git a/manual/Unit posix b/manual/Unit posix
index 66325a6a..170c644a 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 0277cc59..90fedd5c 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 d3a2620f..7ff3d5f0 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)))))
diff --git a/types.db b/types.db
index 940c6e04..b7b61218 100644
--- a/types.db
+++ b/types.db
@@ -1717,7 +1717,8 @@
 (process-execute
  (#(procedure #:clean #:enforce) process-execute (string #!optional (list-of string) (list-of string)) noreturn))
 
-(process-fork (#(procedure #:enforce) process-fork (#!optional (procedure () . *)) fixnum))
+(process-fork (#(procedure #:enforce) process-fork (#!optional (procedure () . *) *) fixnum))
+
 (process-group-id (#(procedure #:clean #:enforce) process-group-id () fixnum))
 (process-run (#(procedure #:clean #:enforce) process-run (string #!optional (list-of string)) fixnum))
 (process-signal (#(procedure #:clean #:enforce) process-signal (fixnum #!optional fixnum) undefined))