X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=c77d056858111426d8e6729a3f283e2b5478170b;hb=a4882e3023fdd5e777169a4cbede33605281173c;hp=89207293ae8ae63023b1ebda73eb439ed7af686b;hpb=0b5119848b6b8713e473fa669356645747e11dbd;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 8920729..c77d056 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,11 @@ (in-package "SB!THREAD") +;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is +;;; necessary because threads are only supported with the conservative +;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS) +;;; are treated as references. + ;;; set the doc here because in early-thread FDOCUMENTATION is not ;;; available, yet #!+sb-doc @@ -64,10 +69,11 @@ in future versions." (declaim (inline current-thread-sap-id)) (defun current-thread-sap-id () - (sb!sys:sap-int + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) (defun init-initial-thread () + (/show0 "Entering INIT-INITIAL-THREAD") (let ((initial-thread (%make-thread :name "initial thread" :%alive-p t :os-thread (current-thread-sap-id)))) @@ -94,35 +100,76 @@ in future versions." (define-alien-routine "block_blockable_signals" void) - (declaim (inline futex-wait futex-wake)) - - (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) - - (sb!alien:define-alien-routine "futex_wake" - int (word unsigned-long) (n unsigned-long))) + #!+sb-lutex + (progn + (declaim (inline %lutex-init %lutex-wait %lutex-wake + %lutex-lock %lutex-unlock)) + + (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + int (lutex unsigned-long)) + + (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait) + int (queue-lutex unsigned-long) (mutex-lutex unsigned-long)) + + (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake) + int (lutex unsigned-long) (n int)) + + (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) + int (lutex unsigned-long)) + + (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) + int (lutex unsigned-long)) + + (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + int (lutex unsigned-long)) + + ;; FIXME: Defining a whole bunch of alien-type machinery just for + ;; passing primitive lutex objects directly to foreign functions + ;; doesn't seem like fun right now. So instead we just manually + ;; pin the lutex, get its address, and let the callee untag it. + (defmacro with-lutex-address ((name lutex) &body body) + `(let ((,name ,lutex)) + (with-pinned-objects (,name) + (let ((,name (sb!kernel:get-lisp-obj-address ,name))) + ,@body)))) + + (defun make-lutex () + (/show0 "Entering MAKE-LUTEX") + ;; Suppress GC until the lutex has been properly registered with + ;; the GC. + (without-gcing + (let ((lutex (sb!vm::%make-lutex))) + (/show0 "LUTEX=..") + (/hexstr lutex) + (with-lutex-address (lutex lutex) + (%lutex-init lutex)) + lutex)))) + + #!-sb-lutex + (progn + (declaim (inline futex-wait futex-wake)) + + (sb!alien:define-alien-routine "futex_wait" + int (word unsigned-long) (old-value unsigned-long)) + + (sb!alien:define-alien-routine "futex_wake" + int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts #!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) + (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) ;;;; spinlocks -(defstruct spinlock - #!+sb-doc - "Spinlock type." - (name nil :type (or null simple-string)) - (value 0)) - (declaim (inline get-spinlock release-spinlock)) ;;; The bare 2 here and below are offsets of the slots in the struct. ;;; There ought to be some better way to get these numbers -(defun get-spinlock (spinlock new-value) +(defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread (ignore spinlock new-value)) @@ -130,7 +177,7 @@ in future versions." ;; store any value #!+sb-thread (loop until - (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0))) + (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0))) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) @@ -145,19 +192,13 @@ in future versions." (defmacro with-spinlock ((spinlock) &body body) (sb!int:with-unique-names (lock) `(let ((,lock ,spinlock)) - (get-spinlock ,lock *current-thread*) + (get-spinlock ,lock) (unwind-protect (progn ,@body) (release-spinlock ,lock))))) ;;;; mutexes -(defstruct mutex - #!+sb-doc - "Mutex type." - (name nil :type (or null simple-string)) - (value nil)) - #!+sb-doc (setf (sb!kernel:fdocumentation 'make-mutex 'function) "Create a mutex." @@ -166,23 +207,25 @@ in future versions." (sb!kernel:fdocumentation 'mutex-value 'function) "The value of the mutex. NIL if the mutex is free. Setfable.") -#!+sb-thread -(declaim (inline mutex-value-address)) -#!+sb-thread -(defun mutex-value-address (mutex) - (declare (optimize (speed 3))) - (sb!ext:truly-the - sb!vm:word - (+ (sb!kernel:get-lisp-obj-address mutex) - (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) - -(defun get-mutex (mutex &optional new-value (wait-p t)) +#!+(and sb-thread (not sb-lutex)) +(progn + (declaim (inline mutex-value-address)) + (defun mutex-value-address (mutex) + (declare (optimize (speed 3))) + (sb!ext:truly-the + sb!vm:word + (+ (sb!kernel:get-lisp-obj-address mutex) + (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))) + +(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) #!+sb-doc "Acquire MUTEX, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" (declare (type mutex mutex) (optimize (speed 3))) - (unless new-value (setf new-value *current-thread*)) + (/show0 "Entering GET-MUTEX") + (unless new-value + (setq new-value *current-thread*)) #!-sb-thread (let ((old-value (mutex-value mutex))) (when (and old-value wait-p) @@ -192,28 +235,44 @@ until it is available" (setf (mutex-value mutex) new-value) t) #!+sb-thread - (let (old) + (progn (when (eql new-value (mutex-value mutex)) (warn "recursive lock attempt ~S~%" mutex) (format *debug-io* "Thread: ~A~%" *current-thread*) (sb!debug:backtrace most-positive-fixnum *debug-io*) (force-output *debug-io*)) - (loop - (unless - (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value)) - (return t)) - (unless wait-p (return nil)) - (futex-wait (mutex-value-address mutex) - (sb!kernel:get-lisp-obj-address old))))) + ;; FIXME: sb-lutex and (not wait-p) + #!+sb-lutex + (when wait-p + (with-lutex-address (lutex (mutex-lutex mutex)) + (%lutex-lock lutex)) + (setf (mutex-value mutex) new-value)) + #!-sb-lutex + (let (old) + (loop + (unless + (setf old (sb!vm::%instance-set-conditional mutex 2 nil + new-value)) + (return t)) + (unless wait-p (return nil)) + (with-pinned-objects (mutex old) + (futex-wait (mutex-value-address mutex) + (sb!kernel:get-lisp-obj-address old))))))) (defun release-mutex (mutex) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for this mutex." (declare (type mutex mutex)) + (/show0 "Entering RELEASE-MUTEX") (setf (mutex-value mutex) nil) #!+sb-thread - (futex-wake (mutex-value-address mutex) 1)) + (progn + #!+sb-lutex + (with-lutex-address (lutex (mutex-lutex mutex)) + (%lutex-unlock lutex)) + #!-sb-lutex + (futex-wake (mutex-value-address mutex) 1))) ;;;; waitqueues/condition variables @@ -221,6 +280,9 @@ this mutex." #!+sb-doc "Waitqueue type." (name nil :type (or null simple-string)) + #!+(and sb-lutex sb-thread) + (lutex (make-lutex)) + #!-sb-lutex (data nil)) (defun make-waitqueue (&key name) @@ -232,15 +294,15 @@ this mutex." (setf (sb!kernel:fdocumentation 'waitqueue-name 'function) "The name of the waitqueue. Setfable.") -#!+sb-thread -(declaim (inline waitqueue-data-address)) -#!+sb-thread -(defun waitqueue-data-address (waitqueue) - (declare (optimize (speed 3))) - (sb!ext:truly-the - sb!vm:word - (+ (sb!kernel:get-lisp-obj-address waitqueue) - (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) +#!+(and sb-thread (not sb-lutex)) +(progn + (declaim (inline waitqueue-data-address)) + (defun waitqueue-data-address (waitqueue) + (declare (optimize (speed 3))) + (sb!ext:truly-the + sb!vm:word + (+ (sb!kernel:get-lisp-obj-address waitqueue) + (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))) (defun condition-wait (queue mutex) #!+sb-doc @@ -252,6 +314,15 @@ time we reacquire MUTEX and return to the caller." #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let ((value (mutex-value mutex))) + (/show0 "CONDITION-WAITing") + #!+sb-lutex + (progn + (setf (mutex-value mutex) nil) + (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) + (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) + (%lutex-wait queue-lutex-address mutex-lutex-address))) + (setf (mutex-value mutex) value)) + #!-sb-lutex (unwind-protect (let ((me *current-thread*)) ;; XXX we should do something to ensure that the result of this setf @@ -263,8 +334,9 @@ time we reacquire MUTEX and return to the caller." ;; this comment, it will change queue->data, and so ;; futex-wait returns immediately instead of sleeping. ;; Ergo, no lost wakeup - (futex-wait (waitqueue-data-address queue) - (sb!kernel:get-lisp-obj-address me))) + (with-pinned-objects (queue me) + (futex-wait (waitqueue-data-address queue) + (sb!kernel:get-lisp-obj-address me)))) ;; If we are interrupted while waiting, we should do these things ;; before returning. Ideally, in the case of an unhandled signal, ;; we should do them before entering the debugger, but this is @@ -278,20 +350,32 @@ time we reacquire MUTEX and return to the caller." #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (declare (type (and fixnum (integer 1)) n)) + (/show0 "Entering CONDITION-NOTIFY") #!+sb-thread - (let ((me *current-thread*)) + (progn + #!+sb-lutex + (with-lutex-address (lutex (waitqueue-lutex queue)) + (%lutex-wake lutex n)) ;; no problem if >1 thread notifies during the comment in ;; condition-wait: as long as the value in queue-data isn't the ;; waiting thread's id, it matters not what it is ;; XXX we should do something to ensure that the result of this setf ;; is visible to all CPUs - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) n))) + #!-sb-lutex + (let ((me *current-thread*)) + (progn + (setf (waitqueue-data queue) me) + (with-pinned-objects (queue) + (futex-wake (waitqueue-data-address queue) n)))))) (defun condition-broadcast (queue) #!+sb-doc "Notify all threads waiting on QUEUE." - (condition-notify queue most-positive-fixnum)) + (condition-notify queue + ;; On a 64-bit platform truncating M-P-F to an int results + ;; in -1, which wakes up only one thread. + (ldb (byte 29 0) + most-positive-fixnum))) ;;;; semaphores @@ -349,16 +433,18 @@ this semaphore, then N of them is woken up." #!-sb-thread `(locally ,@body) #!+sb-thread - `(sb!sys:without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(without-interrupts + (with-mutex ((session-lock ,session)) + ,@body))) (defun new-session () (make-session :threads (list *current-thread*) :interactive-threads (list *current-thread*))) (defun init-job-control () - (setf *session* (new-session))) + (/show0 "Entering INIT-JOB-CONTROL") + (setf *session* (new-session)) + (/show0 "Exiting INIT-JOB-CONTROL")) (defun %delete-thread-from-session (thread session) (with-session-lock (session) @@ -382,6 +468,12 @@ this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (with-mutex (*all-threads-lock*) + (/show0 "HANDLING THREAD EXIT") + #!+sb-lutex + (when (thread-interruptions-lock thread) + (/show0 "FREEING MUTEX LUTEX") + (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) + (%lutex-destroy lutex))) (setq *all-threads* (delete thread *all-threads*))) (when *session* (%delete-thread-from-session thread *session*))) @@ -423,6 +515,7 @@ interactive." #!+sb-thread (let ((was-foreground t)) (loop + (/show0 "Looping in GET-FOREGROUND") (with-session-lock (*session*) (let ((int-t (session-interactive-threads *session*))) (when (eq (car int-t) *current-thread*) @@ -465,16 +558,16 @@ have the foreground next." (labels ((thread-repl () (sb!unix::unix-setsid) (let* ((sb!impl::*stdin* - (sb!sys:make-fd-stream in :input t :buffering :line - :dual-channel-p t)) + (make-fd-stream in :input t :buffering :line + :dual-channel-p t)) (sb!impl::*stdout* - (sb!sys:make-fd-stream out :output t :buffering :line + (make-fd-stream out :output t :buffering :line :dual-channel-p t)) (sb!impl::*stderr* - (sb!sys:make-fd-stream err :output t :buffering :line + (make-fd-stream err :output t :buffering :line :dual-channel-p t)) (sb!impl::*tty* - (sb!sys:make-fd-stream err :input t :output t + (make-fd-stream err :input t :output t :buffering :line :dual-channel-p t)) (sb!impl::*descriptor-handlers* nil)) @@ -539,13 +632,12 @@ returns the thread exits." ;; reference to this thread (handle-thread-exit thread))))))) (values)))) - (sb!sys:with-pinned-objects (initial-function) + ;; Keep INITIAL-FUNCTION pinned until the child thread is + ;; initialized properly. + (with-pinned-objects (initial-function) (let ((os-thread - ;; don't let the child inherit *CURRENT-THREAD* because that - ;; can prevent gc'ing this thread while the child runs - (let ((*current-thread* nil)) - (%create-thread - (sb!kernel:get-lisp-obj-address initial-function))))) + (%create-thread + (sb!kernel:get-lisp-obj-address initial-function)))) (when (zerop os-thread) (error "Can't create a new thread")) (wait-on-semaphore setup-sem) @@ -566,20 +658,23 @@ returns the thread exits." #!+sb-doc (setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) - "The thread that was not interrupted." - (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function) - "The reason why the interruption failed.") + "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(sb!sys:without-interrupts + `(without-interrupts (with-mutex ((thread-interruptions-lock ,thread)) ,@body))) ;; Called from the signal handler. (defun run-interruption () - (let ((interruption (with-interruptions-lock (*current-thread*) - (pop (thread-interruptions *current-thread*))))) - (funcall interruption))) + (in-interruption () + (loop + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (if interruption + (with-interrupts + (funcall interruption)) + (return)))))) ;; The order of interrupt execution is peculiar. If thread A ;; interrupts thread B with I1, I2 and B for some reason receives I1 @@ -591,7 +686,7 @@ returns the thread exits." (defun interrupt-thread (thread function) #!+sb-doc "Interrupt the live THREAD and make it run FUNCTION. A moderate -degree of care is expected for use of interrupt-thread, due to its +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." @@ -626,21 +721,20 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (defun thread-sap-for-id (id) (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))) (loop - (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) (return nil)) - (let ((os-thread (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) - (print os-thread) + (when (sap= thread-sap (int-sap 0)) (return nil)) + (let ((os-thread (sap-ref-word thread-sap + (* sb!vm:n-word-bytes + sb!vm::thread-os-thread-slot)))) (when (= os-thread id) (return thread-sap)) (setf thread-sap - (sb!sys:sap-ref-sap thread-sap (* sb!vm:n-word-bytes - sb!vm::thread-next-slot))))))) + (sap-ref-sap thread-sap (* sb!vm:n-word-bytes + sb!vm::thread-next-slot))))))) #!+sb-thread (defun symbol-value-in-thread (symbol thread-sap) (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) + (tl-val (sap-ref-word thread-sap + (* sb!vm:n-word-bytes index)))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) (sb!kernel:make-lisp-obj tl-val))))