From be2694b7e1b74f7752c9993ba215a8024b88bdf7 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sun, 9 Aug 2020 22:22:53 -0400 Subject: [PATCH] Key *all-threads* by primitive thread address, not stack base This should allow enabling :pauseless-threadstart for win32 but this change does not do that yet. --- float-math.lisp-expr | 2 ++ src/code/alien-callback.lisp | 2 +- src/code/debug.lisp | 21 ++++++++------ src/code/target-thread.lisp | 53 ++++++++++++++++++++---------------- src/code/thread-structs.lisp | 9 +++--- src/cold/shared.lisp | 2 ++ tests/threads.impure.lisp | 4 ++- 7 files changed, 56 insertions(+), 37 deletions(-) diff --git a/float-math.lisp-expr b/float-math.lisp-expr index 59088a7af..d6490ef79 100644 --- a/float-math.lisp-expr +++ b/float-math.lisp-expr @@ -2278,6 +2278,7 @@ (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000) #.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) NIL) @@ -2732,6 +2733,7 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000)) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp index 6369ac6da..bbfca867f 100644 --- a/src/code/alien-callback.lisp +++ b/src/code/alien-callback.lisp @@ -320,7 +320,7 @@ the alien callback for that function with the given alien type." nil nil))) ; sigmask + fpu state bits (copy-primitive-thread-fields thread) (setf (thread-startup-info thread) startup-info) - (update-all-threads (get-lisp-obj-address sb-vm:*control-stack-start*) thread) + (update-all-threads (thread-primitive-thread thread) thread) (run)) #-pauseless-threadstart (dx-let ((args (list index return arguments))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index e0d2f973a..69223a339 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -465,14 +465,19 @@ information." (< a (get-lisp-obj-address sb-vm:*control-stack-end*))) sb-thread:*current-thread*) (all-threads - ;; find a stack whose base is nearest and below A. - (awhen (sb-thread::avl-find<= a sb-thread::*all-threads*) - (let ((thread (sb-thread::avlnode-data it))) - (when (and (< a (sb-thread::thread-stack-end thread)) - ;; Make a final check that it's live. - ;; It could die by the time this returns. - (sb-thread:thread-alive-p thread)) - thread)))))))) + (macrolet ((in-stack-range-p () + `(and (>= a (sb-thread::thread-control-stack-start thread)) + (< a (sb-thread::thread-control-stack-end thread))))) + #+win32 ; exhaustive search + (dolist (thread (sb-thread:list-all-threads)) ; conses, but I don't care + (when (sb-thread::in-stack-range-p) + (return thread))) + #-win32 + ;; find a stack whose primitive-thread is nearest and above A. + (awhen (sb-thread::avl-find>= a sb-thread::*all-threads*) + (let ((thread (sb-thread::avlnode-data it))) + (when (in-stack-range-p) + thread))))))))) ;;;; frame printing diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index a66f9ae2e..ab3c92412 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -229,8 +229,8 @@ an error in that case." ;;; Keep an AVL tree of threads ordered by stack base address. NIL is the empty tree. (sb-ext:define-load-time-global *all-threads* ()) ;;; Ensure that THREAD is in *ALL-THREADS*. -(defmacro update-all-threads (stack-base thread) - `(let ((addr ,stack-base)) +(defmacro update-all-threads (key thread) + `(let ((addr ,key)) (barrier (:read)) (let ((old *all-threads*)) (loop @@ -307,9 +307,11 @@ created and old ones may exit at any time." ;;; Copy some slots from the C 'struct thread' into the SB-THREAD:THREAD. (defmacro copy-primitive-thread-fields (this) `(setf (thread-primitive-thread ,this) (sap-int (current-thread-sap)) - (thread-stack-end ,this) (get-lisp-obj-address sb-vm:*control-stack-end*) (thread-os-thread ,this) (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-thread-slot)))) +(defmacro set-thread-control-stack-slots (this) + `(setf (thread-control-stack-start ,this) (get-lisp-obj-address sb-vm:*control-stack-start*) + (thread-control-stack-end ,this) (get-lisp-obj-address sb-vm:*control-stack-end*))) ;;; Not uncoincidentally, the variables assigned here are also ;;; listed in SB-KERNEL::*SAVE-LISP-CLOBBERED-GLOBALS* @@ -320,6 +322,7 @@ created and old ones may exit at any time." (let* ((name "main thread") (thread (%make-thread name nil (make-semaphore :name name)))) (copy-primitive-thread-fields thread) + (set-thread-control-stack-slots thread) ;; Run the macro-generated function which writes some values into the TLS, ;; most especially *CURRENT-THREAD*. (init-thread-local-storage thread) @@ -327,7 +330,9 @@ created and old ones may exit at any time." (setf *joinable-threads* nil) #-sb-safepoint (setq *foreign-thread* (make-foreign-thread)) (setq *all-threads* - (avl-insert nil (get-lisp-obj-address sb-vm:*control-stack-start*) thread)))) + (avl-insert nil + (sb-thread::thread-primitive-thread sb-thread:*current-thread*) + thread)))) (defun main-thread () "Returns the main thread of the process." @@ -1414,6 +1419,8 @@ on this semaphore, then N of them is woken up." (%exit)) ;; Lisp-side cleanup (let* ((thread *current-thread*) + ;; use the "funny fixnum" representation + (c-thread (%make-lisp-obj (thread-primitive-thread thread))) (sem (thread-semaphore thread))) ;; This AVER failed when I messed up deletion from *STARTING-THREADS*. ;; That in turn caused a failure in GC because a fixnum is not a legal value @@ -1428,8 +1435,7 @@ on this semaphore, then N of them is woken up." ;; pointer, but it knows that it has no underlying OS thread. (with-interruptions-lock (thread) (when sem ; ordinary lisp thread, not FOREIGN-THREAD - (setf (thread-startup-info thread) ; use the "funny fixnum" representation - (%make-lisp-obj (thread-primitive-thread thread)))) + (setf (thread-startup-info thread) c-thread)) (setf (thread-primitive-thread thread) 0) (barrier (:write))) ;; After making the thread dead, remove from session. If this were done first, @@ -1451,8 +1457,7 @@ on this semaphore, then N of them is woken up." ;; With #+pauseless-threadstart, this occurs for FOREIGN-THREAD because ;; the memory allocation/deallocation is handled in C. ;; I would like to combine the recycle bin for foreign and lisp threads though. - (delete-from-all-threads - (get-lisp-obj-address sb-vm:*control-stack-start*)))) + (delete-from-all-threads (get-lisp-obj-address c-thread)))) (when sem (setf (thread-semaphore thread) nil) ; nobody needs to wait on it now ;; We could increment by most-positive-fixnum, but that might just encourage @@ -1462,6 +1467,7 @@ on this semaphore, then N of them is woken up." ;;; The "funny fixnum" address format would do no good - AVL-FIND and AVL-DELETE ;;; expect normal happy lisp integers, even if a bignum. (defun delete-from-all-threads (addr) + (declare (type sb-vm:word addr)) (barrier (:read)) (let ((old *all-threads*)) (loop @@ -1702,8 +1708,7 @@ session." (let ((c-thread (descriptor-sap (thread-startup-info thread)))) (setf (thread-startup-info thread) 0) ;; Clean up *ALL-THREADS* - (delete-from-all-threads - (sap-ref-word c-thread (ash sb-vm::thread-control-stack-start-slot sb-vm:word-shift))) + (delete-from-all-threads (sap-int c-thread)) ;; Free the pthread resources (let ((posix-thread (thread-os-thread thread))) (alien-funcall (extern-alien "pthread_join" (function int unsigned unsigned)) @@ -1793,9 +1798,6 @@ session." (sb-unix::unblock-deferrable-signals))))) ;; notinline keeps array off the call stack by getting it out of the curent frame (declare (notinline unmask-signals)) - - (sb-ext:atomic-push *current-thread* (session-new-enrollees *session*)) - ;; Signals other than stop-for-GC are masked. The WITH/WITHOUT noise is ;; pure cargo-cultism. (without-interrupts (with-local-interrupts ,@body)))))) @@ -1807,7 +1809,7 @@ session." (macrolet ((unmask-signals () '(sb-unix::unblock-deferrable-signals)) (apply-real-function () '(apply function arguments))) (copy-primitive-thread-fields thread) - (update-all-threads (get-lisp-obj-address sb-vm:*control-stack-start*) thread) + (update-all-threads (thread-primitive-thread thread) thread) (sb-ext:atomic-push thread (session-new-enrollees *session*)) (when setup-sem (signal-semaphore setup-sem) @@ -1819,6 +1821,7 @@ session." ;;; All threads other than the initial thread start via this function. #+sb-thread (thread-trampoline-defining-macro + (set-thread-control-stack-slots *current-thread*) #+linux (let ((name (thread-name *current-thread*))) ;; "The thread name is a meaningful C language string, whose length is ;; restricted to 16 characters, including the terminating null byte ('\0'). @@ -1964,9 +1967,6 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." (pthread-sigmask sb-unix::SIG_BLOCK (foreign-symbol-sap "deferrable_sigset" t) saved-sigmask)) (binding* ((thread-sap (allocate-thread-memory) :EXIT-IF-NULL) - (stack-base - (sap-ref-word thread-sap - (ash sb-vm::thread-control-stack-start-slot sb-vm:word-shift))) (sigmask (if (position 1 saved-sigmask) ; if there are any signals masked (copy-seq saved-sigmask) ; heap-allocate to pass to the new thread @@ -1974,9 +1974,9 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." (cell (list thread)) (startup-info (vector trampoline cell function arguments sigmask - #+darwin ; pass fp modes, clearing the accrued exception bits - (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes)) - #-darwin 0))) ; otherwise, don't need to do that + ;; pass fp modes if neccessary, clearing the accrued exception bits + (+ #+(or win32 darwin freebsd) + (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes)))))) (setf (thread-primitive-thread thread) (sap-int thread-sap) (thread-startup-info thread) startup-info) ;; Add new thread to *ALL-THREADS* now so that if the creator asserts @@ -1984,7 +1984,9 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." ;; But there is a slight ploy involved: the thread does not appear in ;; (LIST-ALL-THREADS) until a POSIX thread is successfully started. (setf (thread-%visible thread) 0) - (update-all-threads stack-base thread) + (update-all-threads (sap-int thread-sap) thread) + (when *session* + (sb-ext:atomic-push thread (session-new-enrollees *session*))) ;; Absence of the startup semaphore notwithstanding, creation is synchronized ;; so that we can prevent new threads from starting, typically in SB-POSIX:FORK ;; or SAVE-LISP-AND-DIE. @@ -2005,14 +2007,19 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." sb-vm:word-shift)) thread) (setq created (pthread-create thread thread-sap)) - (cond (created ; Still holding the MAKE-THREAD-LOCK, expose thread in (LIST-ALL-THREADS). + (cond (created + ;; Still holding the MAKE-THREAD-LOCK, expose the thread in *all-threads*. + ;; In this manner, anyone who acquires the MAKE-THREAD-LOCK can be sure that + ;; (list-all-threads) enumerates every running thread. ;; On CPUs where CAS can spuriously fail, this probably needs to loop and retry. ;; It's ok if the thread changed 0 -> {1 | -1}, then failure here is correct. (sb-ext:cas (thread-%visible thread) 0 1)) (t ; unlikely. Out of memory perhaps? (setq *starting-threads* old))))) (unless created ; Remove side-effects of trying to create - (delete-from-all-threads stack-base) + (delete-from-all-threads (sap-int thread-sap)) + (when *session* + (%delete-thread-from-session thread)) (free-thread-struct thread-sap))) (with-pinned-objects (saved-sigmask) (pthread-sigmask sb-unix::SIG_SETMASK saved-sigmask nil)) diff --git a/src/code/thread-structs.lisp b/src/code/thread-structs.lisp index 217e294b9..7d589f905 100644 --- a/src/code/thread-structs.lisp +++ b/src/code/thread-structs.lisp @@ -103,12 +103,13 @@ in future versions." ;; Any use of THREAD-OS-THREAD from lisp should take care to ensure validity of ;; the thread id by holding the INTERRUPTIONS-LOCK. (os-thread 0 :type sb-vm:word) - ;; Keep a copy of CONTROL-STACK-END from the "primitive" thread. - ;; Reading that memory for any thread except *CURRENT-THREAD* is not safe - ;; due to possible unmapping on thread death. + ;; Keep a copy of the stack range for use in SB-EXT:STACK-ALLOCATED-P so that + ;; we don't have to read it from the primitive thread which is unsafe for any + ;; thread other than the current thread. ;; Usually this is a fixed amount below PRIMITIVE-THREAD, but the exact offset ;; varies by build configuration, and if #+win32 it is not related in any way. - (stack-end 0 :type sb-vm:word) + (control-stack-start 0 :type sb-vm:word) + (control-stack-end 0 :type sb-vm:word) ;; At the beginning of the thread's life, this is a vector of data required ;; to start the user code. At the end, is it pointer to the 'struct thread' ;; so that it can be either freed or reused. diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 12c66c385..a9dedffa0 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -309,6 +309,8 @@ ":SB-SAFEPOINT not supported on selected architecture") ("(and sb-safepoint-strictly (not sb-safepoint))" ":SB-SAFEPOINT-STRICTLY requires :SB-SAFEPOINT") + ("(and os-thread-stack sb-safepoint)" + ":OS-THREAD-STACK and :SB-SAFEPOINT are incompatible") ("(not (or elf mach-o win32))" "No execute object file format feature defined") ("(and cons-profiling (not sb-thread))" ":CONS-PROFILING requires :SB-THREAD") diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index c7523057a..e82d501e6 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -150,8 +150,10 @@ (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () + ;; I honestly have no idea what this is testing. + ;; It seems to be nothing more than an implementation change detector test. (assert (sb-thread::avl-find - (sb-kernel:get-lisp-obj-address sb-vm:*control-stack-start*) + (sb-thread::thread-primitive-thread sb-thread:*current-thread*) sb-thread::*all-threads*)) (sleep 2)))) (new-threads (list-all-threads)))