[Sbcl-commits] CVS: sbcl/src/code load.lisp,1.25,1.25.8.1 serve-event.lisp,1.9,1.9.10.1 target-thread.lisp,1.1.4.3,1.1.4.4 thread.lisp,1.1.2.1,1.1.2.2

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

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

Modified Files:
      Tag: dan_native_threads_2_branch
	load.lisp serve-event.lisp target-thread.lisp thread.lisp 
Log Message:
0.7.11.10.thread.5
	Commit build-order.lisp-expr change missed last time

	Fasloader now surrounded by *big-compiler-lock* (it would
	be nice to use a second lock, but as compiler and fasloader
	are mutually recursive, probably asking for trouble)

	serve-event changes: *descriptor-handlers* now has 
	thread-local binding - after all, so do the fds

	More fiddling with locks: whatever descriptor-sap does, "give
	the desired answer" is not it.  So, use explicit shifts instead

	x86 linux version of arch_os_get_current_thread that
	references %gs, so avoiding use of a syscall.



Index: load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/load.lisp,v
retrieving revision 1.25
retrieving revision 1.25.8.1
diff -u -d -r1.25 -r1.25.8.1
--- load.lisp	31 Aug 2002 23:36:58 -0000	1.25
+++ load.lisp	23 Jan 2003 00:25:16 -0000	1.25.8.1
@@ -16,6 +16,12 @@
 
 (in-package "SB!FASL")
 
+;;;; There looks to be an exciting amount of state being modified
+;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
+;;;; around deciding how to thread-safetify it.  So we use a Big Lock.
+;;;; Because this code is mutually recursive with the compiler, we use
+;;;; the *big-compiler-lock*
+
 ;;;; miscellaneous load utilities
 
 ;;; Output the current number of semicolons after a fresh-line.
@@ -327,25 +333,21 @@
   (when (zerop (file-length stream))
     (error "attempt to load an empty FASL file:~%  ~S" (namestring stream)))
   (maybe-announce-load stream verbose)
-  (let* ((*fasl-input-stream* stream)
-	 (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
-	 (*current-fop-table-size* (length *current-fop-table*))
-	 (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
-    (unwind-protect
-	;; FIXME: This should probably become
-	;;   (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
-	;; but as a LOOP newbie I don't want to do that until I can
-	;; test it.
-	(do ((loaded-group (load-fasl-group stream) (load-fasl-group stream)))
-	    ((not loaded-group)))
-      (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
-      (push *current-fop-table* *free-fop-tables*)
-      ;; NIL out the stack and table, so that we don't hold onto garbage.
-      ;;
-      ;; FIXME: Couldn't we just get rid of the free fop table pool so
-      ;; that some of this NILing out would go away?
-      (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
-      (fill *current-fop-table* nil)))
+  (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*)
+    (let* ((*fasl-input-stream* stream)
+	   (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
+	   (*current-fop-table-size* (length *current-fop-table*))
+	   (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
+      (unwind-protect
+	   (loop while (load-fasl-group stream))
+	(setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+	(push *current-fop-table* *free-fop-tables*)
+	;; NIL out the stack and table, so that we don't hold onto garbage.
+	;;
+	;; FIXME: Couldn't we just get rid of the free fop table pool so
+	;; that some of this NILing out would go away?
+	(fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
+	(fill *current-fop-table* nil))))
   t)
 
 ;;; This is used in in target-load and also genesis, using

Index: serve-event.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/serve-event.lisp,v
retrieving revision 1.9
retrieving revision 1.9.10.1
diff -u -d -r1.9 -r1.9.10.1
--- serve-event.lisp	12 Jan 2002 19:33:14 -0000	1.9
+++ serve-event.lisp	23 Jan 2003 00:25:16 -0000	1.9.10.1
@@ -279,11 +279,9 @@
 
 ;;; When a *periodic-polling-function* is defined the server will not
 ;;; block for more than the maximum event timeout and will call the
-;;; polling function if it does time out. One important use of this
-;;; is to periodically call process-yield.
+;;; polling function if it does time out.
 (declaim (type (or null function) *periodic-polling-function*))
-(defvar *periodic-polling-function*
-  #!-mp nil #!+mp #'sb!mp:process-yield)
+(defvar *periodic-polling-function* nil)
 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
 (defvar *max-event-to-sec* 1)
 (defvar *max-event-to-usec* 0)

Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/Attic/target-thread.lisp,v
retrieving revision 1.1.4.3
retrieving revision 1.1.4.4
diff -u -d -r1.1.4.3 -r1.1.4.4
--- target-thread.lisp	22 Jan 2003 12:49:16 -0000	1.1.4.3
+++ target-thread.lisp	23 Jan 2003 00:25:16 -0000	1.1.4.4
@@ -21,22 +21,23 @@
   (assert (probe-file tty-name))
   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 	 (out (sb!unix:unix-dup in))
-	 (err (sb!unix:unix-dup in))
-	 (sb!impl::*stdin* 
-	  (sb!sys:make-fd-stream in :input t :buffering :line))
-	 (sb!impl::*stdout* 
-	  (sb!sys:make-fd-stream out :output t :buffering :line))
-	 (sb!impl::*stderr* 
-	  (sb!sys:make-fd-stream err :output t :buffering :line))
-	 (sb!impl::*tty* 
-	  (sb!sys:make-fd-stream err :input t :output t :buffering :line)))
+	 (err (sb!unix:unix-dup in)))
     (labels ((thread-repl () 
-	       (sb!impl::handling-end-of-the-world
-		(with-simple-restart 
-		    (destroy-thread
-		     (format nil "~~@<Destroy this thread (~A)~~@:>"
-			     (current-thread-id)))
-		  (sb!impl::toplevel-repl nil)))))
+	       (let* ((sb!impl::*stdin* 
+		       (sb!sys:make-fd-stream in :input t :buffering :line))
+		      (sb!impl::*stdout* 
+		       (sb!sys:make-fd-stream out :output t :buffering :line))
+		      (sb!impl::*stderr* 
+		       (sb!sys:make-fd-stream err :output t :buffering :line))
+		      (sb!impl::*tty* 
+		       (sb!sys:make-fd-stream err :input t :output t :buffering :line))
+		      (sb!impl::*descriptor-handlers* nil))
+		 (sb!impl::handling-end-of-the-world
+		  (with-simple-restart 
+		      (destroy-thread
+		       (format nil "~~@<Destroy this thread (~A)~~@:>"
+			       (current-thread-id)))
+		    (sb!impl::toplevel-repl nil))))))
       (make-thread #'thread-repl))))
 
 ;;;; mutex and read/write locks, originally inspired by CMUCL multi-proc.lisp

Index: thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/Attic/thread.lisp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -d -r1.1.2.1 -r1.1.2.2
--- thread.lisp	22 Jan 2003 12:49:16 -0000	1.1.2.1
+++ thread.lisp	23 Jan 2003 00:25:16 -0000	1.1.2.2
@@ -10,9 +10,10 @@
 #-sb-xc-host
 (defmacro with-recursive-lock ((mutex) &body body)
   (let ((cfp (gensym "CFP")))
-    `(let ((,cfp (sb!sys:sap-int (sb!di::descriptor-sap (sb!vm::current-fp)))))
+    `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
       (unless (and (mutex-value ,mutex)
-		   (SB!DI::control-stack-pointer-valid-p (mutex-value ,mutex)))
+		   (SB!DI::control-stack-pointer-valid-p
+		    (sb!sys:int-sap (ash (mutex-value ,mutex) 2))))
 	(get-mutex ,mutex ,cfp))
       (unwind-protect
 	   (progn ,@body)