[Chicken-hackers] [PATCH] process-fork: option to kill all but the current thread in the child process

[Felix]

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 <address@hidden>
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