From ce0a49644dce03ca07008e8073897e4ed7b247df Mon Sep 17 00:00:00 2001
From: Daniel Barlow <dan@telent.net>
Date: Sat, 29 Nov 2003 00:35:40 +0000
Subject: [PATCH] 0.8.6.11 	Some clean up with unix signals possible now
 that we denote 	them with numbers instead of
 keywords

	Juggled the order in target-thread.lisp to make it compile
	without warning

	Threads now signal SIG_THREAD_EXIT in the parent, not
	SIGALRM.   CLONE_PARENT is no longer used, so the creating
	Lisp thread gets this signal instead of the original C process

	thread-exit_handler is the SIG_THREAD_EXIT handler.  It calls
	the new static function HANDLE-THREAD-EXIT to manipulate
	*SESSION*

	SB!THREAD::*FOREGROUND-THREAD-STACK* ius dead, remove from
	static variables list
---
 src/code/target-signal.lisp       |   18 ++--
 src/code/target-thread.lisp       |  194 +++++++++++++++++++------------------
 src/compiler/generic/genesis.lisp |    3 +-
 src/compiler/x86/parms.lisp       |    2 +-
 src/runtime/interrupt.c           |   28 ++++++
 src/runtime/interrupt.h           |    1 +
 src/runtime/linux-os.c            |    2 +
 src/runtime/linux-os.h            |    1 +
 src/runtime/runtime.c             |    4 +-
 src/runtime/thread.c              |    6 +-
 version.lisp-expr                 |    2 +-
 11 files changed, 147 insertions(+), 114 deletions(-)

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index a920f15..cdcae59 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -17,26 +17,20 @@
 
 ;;;; system calls that deal with signals
 
+;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
+;;; should be a valid signal number
 #!-sb-fluid (declaim (inline real-unix-kill))
-(sb!alien:define-alien-routine ("kill" real-unix-kill) sb!alien:int
+(sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
   (pid sb!alien:int)
   (signal sb!alien:int))
 
-;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
-;;; should be a valid signal number
-(defun unix-kill (pid signal)
-  (real-unix-kill pid signal))
-
+;;; Send the signal SIGNAL to the all the process in process group
+;;; PGRP. SIGNAL should be a valid signal number
 #!-sb-fluid (declaim (inline real-unix-killpg))
-(sb!alien:define-alien-routine ("killpg" real-unix-killpg) sb!alien:int
+(sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
   (pgrp sb!alien:int)
   (signal sb!alien:int))
 
-;;; Send the signal SIGNAL to the all the process in process group
-;;; PGRP. SIGNAL should be a valid signal number
-(defun unix-killpg (pgrp signal)
-  (real-unix-killpg pgrp signal))
-
 ;;; Reset the current set of masked signals (those being blocked from
 ;;; delivery).
 ;;;
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 59e96ad..2390437 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -10,88 +10,10 @@
 
 (sb!alien::define-alien-routine "signal_thread_to_dequeue"
     sb!alien:unsigned-int
-  (thread-pid sb!alien:unsigned-long))
+  (thread-id sb!alien:unsigned-long))
 
 (defvar *session* nil)
 
-(defun make-thread (function)
-  (let* ((real-function (coerce function 'function))
-	 (tid
-	  (%create-thread
-	   (sb!kernel:get-lisp-obj-address
-	    (lambda ()
-	      ;; in time we'll move some of the binding presently done in C
-	      ;; here too
-	      (let ((sb!kernel::*restart-clusters* nil)
-		    (sb!impl::*descriptor-handlers* nil) ; serve-event
-		    (sb!impl::*available-buffers* nil)) ;for fd-stream
-		;; can't use handling-end-of-the-world, because that flushes
-		;; output streams, and we don't necessarily have any (or we
-		;; could be sharing them)
-		(sb!sys:enable-interrupt sb!unix:sigint :ignore)
-		(sb!unix:unix-exit
-		 (catch 'sb!impl::%end-of-the-world 
-		   (with-simple-restart 
-		       (destroy-thread
-			(format nil "~~@<Destroy this thread (~A)~~@:>"
-				(current-thread-id)))
-		     (funcall real-function))
-		   0))))))))
-    (with-mutex ((session-lock *session*))
-      (pushnew tid (session-threads *session*)))
-    tid))
-
-;;; Really, you don't want to use these: they'll get into trouble with
-;;; garbage collection.  Use a lock or a waitqueue instead
-(defun suspend-thread (thread-id)
-  (sb!unix:unix-kill thread-id sb!unix:sigstop))
-(defun resume-thread (thread-id)
-  (sb!unix:unix-kill thread-id sb!unix:sigcont))
-;;; Note warning about cleanup forms
-(defun destroy-thread (thread-id)
-  "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
-  (sb!unix:unix-kill thread-id sb!unix:sigterm)
-  ;; may have been stopped for some reason, so now wake it up to
-  ;; deliver the TERM
-  (sb!unix:unix-kill thread-id sb!unix:sigcont))
-
-
-;;; a moderate degree of care is expected for use of interrupt-thread,
-;;; due to its nature: if you interrupt a thread that was holding
-;;; important locks then do something that turns out to need those
-;;; locks, you probably won't like the effect.  Used with thought
-;;; though, it's a good deal gentler than the last-resort functions above
-
-(defun interrupt-thread (thread function)
-  "Interrupt THREAD and make it run FUNCTION.  "
-  (sb!unix::syscall* ("interrupt_thread"
-		      sb!alien:unsigned-long  sb!alien:unsigned-long)
-		     thread
-		     thread (sb!kernel:get-lisp-obj-address
-			     (coerce function 'function))))
-(defun terminate-thread (thread-id)
-  "Terminate the thread identified by THREAD-ID, by causing it to run
-SB-EXT:QUIT - the usual cleanup forms will be evaluated"
-  (interrupt-thread thread-id 'sb!ext:quit))
-
-(declaim (inline current-thread-id))
-(defun current-thread-id ()
-  (logand 
-   (sb!sys:sap-int
-    (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
-   ;; KLUDGE pids are 16 bit really.  Avoid boxing the return value
-   (1- (ash 1 16))))
-
-;;;; iterate over the in-memory threads
-
-(defun mapcar-threads (function)
-  "Call FUNCTION once for each known thread, giving it the thread structure as argument"
-  (let ((function (coerce function 'function)))
-    (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
-	  then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
-	  until (sb!sys:sap= thread (sb!sys:int-sap 0))
-	  collect (funcall function thread))))
-
 ;;;; queues, locks 
 
 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
@@ -158,6 +80,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 (sb!alien:define-alien-routine
     "futex_wake" int (word unsigned-long) (n unsigned-long))
 
+
 ;;; this should only be called while holding the queue spinlock.
 ;;; it releases the spinlock before sleeping
 (defun wait-on-queue (queue &optional lock)
@@ -325,6 +248,86 @@ time we reacquire LOCK and return to the caller."
 	  (fdefinition 'condition-notify) #'condition-notify/futex)
     t))
 
+(defun make-thread (function)
+  (let* ((real-function (coerce function 'function))
+	 (tid
+	  (%create-thread
+	   (sb!kernel:get-lisp-obj-address
+	    (lambda ()
+	      ;; in time we'll move some of the binding presently done in C
+	      ;; here too
+	      (let ((sb!kernel::*restart-clusters* nil)
+		    (sb!impl::*descriptor-handlers* nil) ; serve-event
+		    (sb!impl::*available-buffers* nil)) ;for fd-stream
+		;; can't use handling-end-of-the-world, because that flushes
+		;; output streams, and we don't necessarily have any (or we
+		;; could be sharing them)
+		(sb!sys:enable-interrupt sb!unix:sigint :ignore)
+		(sb!unix:unix-exit
+		 (catch 'sb!impl::%end-of-the-world 
+		   (with-simple-restart 
+		       (destroy-thread
+			(format nil "~~@<Destroy this thread (~A)~~@:>"
+				(current-thread-id)))
+		     (funcall real-function))
+		   0))))))))
+    (with-mutex ((session-lock *session*))
+      (pushnew tid (session-threads *session*)))
+    tid))
+
+;;; Really, you don't want to use these: they'll get into trouble with
+;;; garbage collection.  Use a lock or a waitqueue instead
+(defun suspend-thread (thread-id)
+  (sb!unix:unix-kill thread-id sb!unix:sigstop))
+(defun resume-thread (thread-id)
+  (sb!unix:unix-kill thread-id sb!unix:sigcont))
+;;; Note warning about cleanup forms
+(defun destroy-thread (thread-id)
+  "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
+  (sb!unix:unix-kill thread-id sb!unix:sigterm)
+  ;; may have been stopped for some reason, so now wake it up to
+  ;; deliver the TERM
+  (sb!unix:unix-kill thread-id sb!unix:sigcont))
+
+     
+     
+
+;;; a moderate degree of care is expected for use of interrupt-thread,
+;;; due to its nature: if you interrupt a thread that was holding
+;;; important locks then do something that turns out to need those
+;;; locks, you probably won't like the effect.  Used with thought
+;;; though, it's a good deal gentler than the last-resort functions above
+
+(defun interrupt-thread (thread function)
+  "Interrupt THREAD and make it run FUNCTION.  "
+  (sb!unix::syscall* ("interrupt_thread"
+		      sb!alien:unsigned-long  sb!alien:unsigned-long)
+		     thread
+		     thread (sb!kernel:get-lisp-obj-address
+			     (coerce function 'function))))
+(defun terminate-thread (thread-id)
+  "Terminate the thread identified by THREAD-ID, by causing it to run
+SB-EXT:QUIT - the usual cleanup forms will be evaluated"
+  (interrupt-thread thread-id 'sb!ext:quit))
+
+(declaim (inline current-thread-id))
+(defun current-thread-id ()
+  (logand 
+   (sb!sys:sap-int
+    (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
+   ;; KLUDGE pids are 16 bit really.  Avoid boxing the return value
+   (1- (ash 1 16))))
+
+;;;; iterate over the in-memory threads
+
+(defun mapcar-threads (function)
+  "Call FUNCTION once for each known thread, giving it the thread structure as argument"
+  (let ((function (coerce function 'function)))
+    (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
+	  then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
+	  until (sb!sys:sap= thread (sb!sys:int-sap 0))
+	  collect (funcall function thread))))
+
 ;;;; job control, independent listeners
 
 (defstruct session 
@@ -341,15 +344,16 @@ time we reacquire LOCK and return to the caller."
 (defun init-job-control ()
   (setf *session* (new-session)))
 
+(defun %delete-thread-from-session (tid)
+  (with-mutex ((session-lock *session*))
+    (setf (session-threads *session*)
+	  (delete tid (session-threads *session*))
+	  (session-interactive-threads *session*)
+	  (delete tid (session-interactive-threads *session*)))))
+
 (defun call-with-new-session (fn)
-  (let ((tid (current-thread-id)))
-    (with-mutex ((session-lock *session*))
-      (setf (session-threads *session*)
-	    (delete tid (session-threads *session*))
-	    (session-interactive-threads *session*)
-	    (delete tid (session-interactive-threads *session*))))
-    (let ((*session* (new-session)))
-      (funcall fn))))
+  (%delete-thread-from-session (current-thread-id))
+  (let ((*session* (new-session)))  (funcall fn)))
 
 (defmacro with-new-session (args &body forms)
   (declare (ignore args))		;for extensibility
@@ -357,6 +361,11 @@ time we reacquire LOCK and return to the caller."
     `(labels ((,fb-name () ,@forms))
       (call-with-new-session (function ,fb-name)))))
 
+;;; this is called from a C signal handler: some signals may be masked
+(defun handle-thread-exit (tid)
+  "Remove thread id TID from the session, if it's there"
+  (%delete-thread-from-session tid))
+  
 (defun terminate-session ()
   "Kill all threads in session exept for this one.  Does nothing if current
 thread is not the foreground thread"
@@ -390,12 +399,13 @@ interactive."
 (defun get-foreground ()
   (loop
    (with-mutex ((session-lock *session*))
-     (let ((tid (current-thread-id)))
-       (when (eql (car (session-interactive-threads *session*)) tid)
+     (let ((tid (current-thread-id))
+	   (int-t (session-interactive-threads *session*)))
+       (when (eql (car int-t) tid)
 	 (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
 	 (return-from get-foreground t))
-       (unless (member tid *interactive-threads*)
-	 (setf (cdr (last (session-interactive-threads *session*)))
+       (unless (member tid int-t)
+	 (setf (cdr (last int-t))
 	       (list tid)))
        (condition-wait
 	(session-interactive-threads-queue *session*)
@@ -406,7 +416,7 @@ interactive."
   (with-mutex ((session-lock *session*))
     (let ((tid (current-thread-id)))
       (setf (session-interactive-threads *session*)
-	    (delete tid *interactive-threads*))
+	    (delete tid (session-interactive-threads *session*)))
       (sb!sys:enable-interrupt sb!unix:sigint :ignore)
       (when next 
 	(setf (session-interactive-threads *session*)
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 7a06d2b..485d71b 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1257,7 +1257,8 @@
     (frob internal-error)
     (frob sb!kernel::control-stack-exhausted-error)
     (frob sb!di::handle-breakpoint)
-    (frob sb!di::handle-fun-end-breakpoint))
+    (frob sb!di::handle-fun-end-breakpoint)
+    (frob sb!thread::handle-thread-exit))
 
   (cold-set '*current-catch-block*          (make-fixnum-descriptor 0))
   (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp
index 234421d..701b42f 100644
--- a/src/compiler/x86/parms.lisp
+++ b/src/compiler/x86/parms.lisp
@@ -226,6 +226,7 @@
     sb!kernel::control-stack-exhausted-error
     sb!di::handle-breakpoint
     fdefinition-object
+    #!+sb-thread sb!thread::handle-thread-exit
 
     ;; free pointers
     ;; 
@@ -250,7 +251,6 @@
     *free-interrupt-context-index*
 
     *free-tls-index*
-    sb!thread::*foreground-thread-stack*
     
     *allocation-pointer*
     *binding-stack-pointer*
diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c
index d7f4a42..7239528 100644
--- a/src/runtime/interrupt.c
+++ b/src/runtime/interrupt.c
@@ -45,6 +45,8 @@
 #include <stdlib.h>
 #include <string.h>
 #include <signal.h>
+#include <sys/types.h>
+#include <sys/wait.h>
 
 #include "runtime.h"
 #include "arch.h"
@@ -62,6 +64,8 @@
 #include "genesis/fdefn.h"
 #include "genesis/simple-fun.h"
 
+
+
 void run_deferred_handler(struct interrupt_data *data, void *v_context) ;
 static void store_signal_data_for_later (struct interrupt_data *data, 
 					 void *handler, int signal,
@@ -105,6 +109,7 @@ void sigaddset_blockable(sigset_t *s)
 #ifdef LISP_FEATURE_SB_THREAD
     sigaddset(s, SIG_STOP_FOR_GC);
     sigaddset(s, SIG_INTERRUPT_THREAD);
+    sigaddset(s, SIG_THREAD_EXIT);
 #endif
 }
 
@@ -666,6 +671,29 @@ void interrupt_thread_handler(int num, siginfo_t *info, void *v_context)
     }
     arrange_return_to_lisp_function(context,info->si_value.sival_int);
 }
+
+void thread_exit_handler(int num, siginfo_t *info, void *v_context)
+{   /* called when a child thread exits */
+    os_context_t *context = (os_context_t*)arch_os_get_context(&v_context);
+    struct thread *th=arch_os_get_current_thread();
+    pid_t kid;
+    int *status;
+    struct interrupt_data *data=
+	th ? th->interrupt_data : global_interrupt_data;
+    if(maybe_defer_handler(thread_exit_handler,data,num,info,context)){
+	return ;
+    }
+    while(1) {
+	kid=waitpid(-1,&status,__WALL|WNOHANG);
+	if(kid<1) break;
+	if(WIFEXITED(status) || WIFSIGNALED(status)) {
+	    struct thread *th=find_thread_by_pid(kid);
+	    if(!th) continue;
+	    funcall1(SymbolFunction(HANDLE_THREAD_EXIT),make_fixnum(kid));
+	    destroy_thread(th);
+	}
+    }
+}
 #endif
 
 boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr){
diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h
index 11eca74..cb71475 100644
--- a/src/runtime/interrupt.h
+++ b/src/runtime/interrupt.h
@@ -53,6 +53,7 @@ extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
 #ifdef LISP_FEATURE_SB_THREAD
 extern void interrupt_thread_handler(int, siginfo_t*, void*);
 extern void sig_stop_for_gc_handler(int, siginfo_t*, void*);
+extern void thread_exit_handler(int, siginfo_t*, void*);
 #endif
 extern void undoably_install_low_level_interrupt_handler (int signal,
 							  void
diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c
index 03d950f..a958224 100644
--- a/src/runtime/linux-os.c
+++ b/src/runtime/linux-os.c
@@ -280,6 +280,8 @@ os_install_interrupt_handlers(void)
 						 interrupt_thread_handler);
     undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
 						 sig_stop_for_gc_handler);
+    undoably_install_low_level_interrupt_handler(SIG_THREAD_EXIT,
+						 thread_exit_handler);
     if(!linux_supports_futex)
 	undoably_install_low_level_interrupt_handler(SIG_DEQUEUE,
 						     sigcont_handler);
diff --git a/src/runtime/linux-os.h b/src/runtime/linux-os.h
index 05729ae..d0f1781 100644
--- a/src/runtime/linux-os.h
+++ b/src/runtime/linux-os.h
@@ -41,4 +41,5 @@ typedef int os_vm_prot_t;
 #define SIG_INTERRUPT_THREAD (SIGRTMIN)
 #define SIG_STOP_FOR_GC (SIGRTMIN+1)
 #define SIG_DEQUEUE (SIGRTMIN+2)
+#define SIG_THREAD_EXIT (SIGRTMIN+3)
 
diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c
index ec0d5bc..6799033 100644
--- a/src/runtime/runtime.c
+++ b/src/runtime/runtime.c
@@ -385,13 +385,12 @@ static void /* noreturn */ parent_loop(void)
 
     sigemptyset(&sigset);
 
-    sigaddset(&sigset, SIGALRM);
     sigaddset(&sigset, SIGCHLD);
+    sigaddset(&sigset, SIG_THREAD_EXIT);
     sigprocmask(SIG_UNBLOCK,&sigset,0);
     sa.sa_handler=parent_sighandler;
     sa.sa_mask=sigset;
     sa.sa_flags=SA_SIGINFO;
-    sigaction(SIGALRM, &sa, 0);
     sigaction(SIGCHLD, &sa, 0);
 
     sigemptyset(&sigset);
@@ -399,6 +398,7 @@ static void /* noreturn */ parent_loop(void)
     sa.sa_mask=sigset;
     sa.sa_flags=0;
     sigaction(SIGINT, &sa, 0);
+    sigaction(SIG_THREAD_EXIT, &sa, 0);
 
     while(!all_threads) {
 	sched_yield();
diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 8ac0519..c0166d0 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -4,9 +4,6 @@
 #include <signal.h>
 #include <stddef.h>
 #include <errno.h>
-#ifndef CLONE_PARENT		/* lameass glibc 2.2  doesn't define this */
-#define CLONE_PARENT 0x00008000	/* even though the manpage documents it */
-#endif
 #include "runtime.h"
 #include "sbcl.h"
 #include "validate.h"		/* for CONTROL_STACK_SIZE etc */
@@ -193,8 +190,7 @@ pid_t create_thread(lispobj initial_function) {
     kid_pid=
 	clone(new_thread_trampoline,
 	      (((void*)th->control_stack_start)+THREAD_CONTROL_STACK_SIZE-4),
-	      (((getpid()!=parent_pid)?(CLONE_PARENT):0)
-	       |CLONE_FILES|SIGALRM|CLONE_VM),th);
+	      CLONE_FILES|SIG_THREAD_EXIT|CLONE_VM,th);
     if(kid_pid<=0) 
 	goto cleanup;
 #else
diff --git a/version.lisp-expr b/version.lisp-expr
index dcab66f..f4e83db 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.6.10"
+"0.8.6.11"
-- 
1.7.10.4