[Openmcl-cvs-notifications] r12798 - in /trunk/source: level-1/l1-lisp-threads.lisp level-1/l1-processes.lisp lisp-kernel/thread_manager.c

[gb at clozure.com]

Author: gb
Date: Wed Sep  9 04:47:04 2009
New Revision: 12798

Log:
Don't copy a thread's termination semaphore to the TCR (so don't
signal it in the last stages of thread termination, possibly after
the lisp pointer to the semaphore has been GCed.)

Do try to signal it from lisp code, at least in cases where the thread
terminates normally (in PROCESS-INITIAL-FORM-EXITED).

Seems to fix ticket:598.

Modified:
    trunk/source/level-1/l1-lisp-threads.lisp
    trunk/source/level-1/l1-processes.lisp
    trunk/source/lisp-kernel/thread_manager.c

Modified: trunk/source/level-1/l1-lisp-threads.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-lisp-threads.lisp (original)
+++ trunk/source/level-1/l1-lisp-threads.lisp Wed Sep  9 04:47:04 2009
@@ -484,15 +484,12 @@
 =

 ;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE.
 (defun %activate-tcr (tcr termination-semaphore allocation-quantum)
+  (declare (ignore termination-semaphore))
   (if (and tcr (not (eql 0 tcr)))
     (with-macptrs (tcrp)
       (%setf-macptr-to-object tcrp tcr)
       (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
             (or allocation-quantum (default-allocation-quantum)))
-      (setf (%get-ptr tcrp target::tcr.termination-semaphore)
-            (if termination-semaphore
-              (semaphore-value termination-semaphore)
-              (%null-ptr)))
       t)))
                          =

 (defvar *canonical-error-value*
@@ -1114,4 +1111,8 @@
 ;;; the global lists.
 (defun %foreign-thread-terminate ()
   (let* ((proc *current-process*))
-    (when proc (remove-from-all-processes proc))))
+    (when proc
+      (remove-from-all-processes proc)
+      (let* ((ts (process-termination-semaphore proc)))
+        (when ts (signal-semaphore ts))))))
+

Modified: trunk/source/level-1/l1-processes.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-processes.lisp (original)
+++ trunk/source/level-1/l1-processes.lisp Wed Sep  9 04:47:04 2009
@@ -318,15 +318,7 @@
     (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate))
     ))
 =

-(defmethod (setf process-termination-semaphore) :after (new (p process))
-  (with-macptrs (tcrp)
-    (%setf-macptr-to-object tcrp (process-tcr p))
-    (unless (%null-ptr-p tcrp)
-      (setf (%get-ptr tcrp target::tcr.termination-semaphore)
-            (if new
-              (semaphore-value new)
-              (%null-ptr))))
-    new))
+
 =

 (defun process-resume (p)
   "Resume a specified process which had previously been suspended
@@ -417,12 +409,13 @@
 =

 ;;; Separated from run-process-initial-form just so I can change it easily.
 (defun process-initial-form-exited (process kill)
-  ;; Enter the *initial-process* and have it finish us up
   (without-interrupts
    (if (eq kill :shutdown)
      (progn
        (setq *whostate* "Shutdown")
        (add-to-shutdown-processes process)))
+   (let* ((semaphore (process-termination-semaphore process)))
+     (when semaphore (signal-semaphore semaphore)))
    (maybe-finish-process-kill process kill)))
 =

 (defun maybe-finish-process-kill (process kill)

Modified: trunk/source/lisp-kernel/thread_manager.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/thread_manager.c (original)
+++ trunk/source/lisp-kernel/thread_manager.c Wed Sep  9 04:47:04 2009
@@ -1380,7 +1380,6 @@
   TCR *tcr =3D TCR_FROM_TSD(arg),*current=3Dget_tcr(0);
 =

   area *vs, *ts, *cs;
-  void *termination_semaphore;
   =

   if (current =3D=3D NULL) {
     current =3D tcr;
@@ -1423,7 +1422,6 @@
     tcr->tlb_pointer =3D NULL;
     tcr->osid =3D 0;
     tcr->interrupt_pending =3D 0;
-    termination_semaphore =3D tcr->termination_semaphore;
     tcr->termination_semaphore =3D NULL;
 #ifdef HAVE_TLS
     dequeue_tcr(tcr);
@@ -1438,9 +1436,6 @@
     tcr->native_thread_info =3D NULL;
 #endif
     UNLOCK(lisp_global(TCR_AREA_LOCK),current);
-    if (termination_semaphore) {
-      SEM_RAISE(termination_semaphore);
-    }
   } else {
     tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
   }