[Sbcl-commits] CVS: sbcl/src/code gc.lisp,1.51,1.52 target-thread.lisp,1.11,1.12

[Daniel B. <da...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv22220/src/code

Modified Files:
	gc.lisp target-thread.lisp 
Log Message:
0.8.4.1
	Merge most of atropos-branch: miscellaneous (mostly threading)
	fixes that were probably a little too risky for late in 0.8.4
	development.

        doc/ - fix up some of the sgml errors that sourceforge keeps 
        mailing me about

        New function release-spinlock that only changes the lock value
        if we owned the spinlock, so good for unwind-protect cleanups
        when lock acquisition failed
        
        get-spinlock release-spinlock current-thread-id could all win
        from being inlinable

        Use a RT signal (SIG_DEQUEUE) for resuming threads that were
        on queues, instead of having SIGCONT do both this and the
        resume-after-gc task.

        Scattered commentary describing the state of the signal mask 
        in various interesting places

        In gencgc alloc, only install a deferred handler for GC if
        there was no previous handler for anything else.  This fixes
        a longstanding bug where the GC thread would eat all cpu while
        waiting indefinitely for othr threads to stop.

        Add SIG_STOP_FOR_GC to the blockable list

        interrupt_maybe_gc_int: enable signals before calling SUB-GC,
        or the locking that sub-gc does is going to interact badly.

        Minor rearrangement to parent thread to stop it having to wake
        up on every GC

        Add grovel_headers line for SIG-DEQUEUE.  OAOOM alert...



Index: gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- gc.lisp	29 Sep 2003 15:35:30 -0000	1.51
+++ gc.lisp	2 Oct 2003 23:13:09 -0000	1.52
@@ -237,25 +237,21 @@
 (defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
 
 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
-  (when *already-in-gc* (return-from sub-gc nil))
-  (setf *need-to-collect-garbage* t)
-  (when (zerop *gc-inhibit*)
-    (sb!thread:with-recursive-lock (*gc-mutex*)
-      (let ((*already-in-gc* t))
-	(without-interrupts
-	 (gc-stop-the-world)
-	 #+nil
-	 (dolist (h *before-gc-hooks*)
-	   (carefully-funcall h))
-	 (collect-garbage gen)
-	 (incf *n-bytes-freed-or-purified*
-	       (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
-	 (setf *need-to-collect-garbage* nil)
-
-	 (gc-start-the-world)))
-      (scrub-control-stack))
-    (dolist (h *after-gc-hooks*)
-      (carefully-funcall h)))
+  ;; catch attempts to gc recursively or during post-hooks and ignore them
+  (when (sb!thread::mutex-value *gc-mutex*)  (return-from sub-gc nil))
+  (sb!thread:with-mutex (*gc-mutex* :wait-p nil)
+    (setf *need-to-collect-garbage* t)
+    (when (zerop *gc-inhibit*)
+      (without-interrupts
+       (gc-stop-the-world)
+       (collect-garbage gen)
+       (incf *n-bytes-freed-or-purified*
+	     (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
+       (setf *need-to-collect-garbage* nil)
+       (gc-start-the-world))
+      (scrub-control-stack)
+      (setf *need-to-collect-garbage* nil)
+      (dolist (h *after-gc-hooks*) (carefully-funcall h))))
   (values))
        
 

Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- target-thread.lisp	1 Sep 2003 07:55:42 -0000	1.11
+++ target-thread.lisp	2 Oct 2003 23:13:09 -0000	1.12
@@ -27,8 +27,8 @@
 	       (funcall real-function))
 	     0))))))))
 
-;;; Conventional wisdom says that it's a bad idea to use these unless
-;;; you really need to.  Use a lock or a waitqueue instead
+;;; 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)
@@ -60,10 +60,13 @@
 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 ()
-  (sb!sys:sap-int
-   (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
+  (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
 
@@ -78,18 +81,28 @@
 ;;;; queues, locks 
 
 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
+(declaim (inline get-spinlock release-spinlock))
+
 (defun get-spinlock (lock offset new-value)
   (declare (optimize (speed 3) (safety 0)))
   (loop until
 	(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
 
+;; this should do nothing if we didn't own the lock, so safe to use in
+;; unwind-protect cleanups when lock acquisition failed for some reason
+(defun release-spinlock (lock offset our-value)
+  (declare (optimize (speed 3) (safety 0)))
+  (sb!vm::%instance-set-conditional lock offset our-value 0))
+
 (defmacro with-spinlock ((queue) &body body)
   (with-unique-names (pid)
-    `(unwind-protect
-      (let ((,pid (current-thread-id)))
-	(get-spinlock ,queue 2 ,pid)
-	,@body)
-      (setf (waitqueue-lock ,queue) 0))))
+    `(let ((,pid (current-thread-id)))
+       (unwind-protect
+	    (progn
+	      (get-spinlock ,queue 2 ,pid)
+	      ,@body)
+	 (release-spinlock ,queue 2 ,pid)))))
+
 
 ;;;; the higher-level locking operations are based on waitqueues
 
@@ -104,12 +117,11 @@
 (sb!alien:define-alien-routine "block_sigcont"  void)
 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
 
+
 ;;; this should only be called while holding the queue spinlock.
 ;;; it releases the spinlock before sleeping
 (defun wait-on-queue (queue &optional lock)
   (let ((pid (current-thread-id)))
-    ;; FIXME what should happen if we get interrupted when we've blocked
-    ;; the sigcont?  For that matter, can we get interrupted?
     (block-sigcont)
     (when lock (release-mutex lock))
     (sb!sys:without-interrupts
@@ -128,12 +140,13 @@
 ;;; this should only be called while holding the queue spinlock.
 (defun signal-queue-head (queue)
   (let ((p (car (waitqueue-data queue))))
-    (when p (sb!unix:unix-kill p  sb!unix:sigcont))))
+    (when p (sb!unix:unix-kill p  sb!unix::sig-dequeue))))
 
 ;;;; mutex
 
 (defun get-mutex (lock &optional new-value (wait-p t))
-  (declare (type mutex lock))
+  (declare (type mutex lock)
+	   (optimize (speed 3)))
   (let ((pid (current-thread-id)))
     (unless new-value (setf new-value pid))
     (assert (not (eql new-value (mutex-value lock))))
@@ -257,8 +270,7 @@
       (sb!impl::repl-prompt-fun out-stream))))
 
 (defun resume-stopped-thread (id)
-  (let ((pid (current-thread-id))
-	(lock *session-lock*)) 
+  (let ((lock *session-lock*)) 
     (with-spinlock (lock)
       (setf (waitqueue-data lock)
 	    (cons id (delete id  (waitqueue-data lock)))))