(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
(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 ()
#!-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))
;; 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))
(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."
(+ (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))
+(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*))
+ (unless new-value
+ (setq new-value *current-thread*))
#!-sb-thread
(let ((old-value (mutex-value mutex)))
(when (and old-value wait-p)
(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)))))
+ (with-pinned-objects (mutex old)
+ (futex-wait (mutex-value-address mutex)
+ (sb!kernel:get-lisp-obj-address old))))))
(defun release-mutex (mutex)
#!+sb-doc
;; 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
;; 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)))
+ (with-pinned-objects (queue)
+ (futex-wake (waitqueue-data-address queue) n))))
(defun condition-broadcast (queue)
#!+sb-doc
#!-sb-thread
`(locally ,@body)
#!+sb-thread
- `(sb!sys:without-interrupts
+ `(without-interrupts
(with-mutex ((session-lock ,session))
,@body)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
- (sb!sys:make-fd-stream in :input t :buffering :line
+ (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))
;; 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)
"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 ()
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ (with-interrupts
+ (funcall interruption)))))
;; The order of interrupt execution is peculiar. If thread A
;; interrupts thread B with I1, I2 and B for some reason receives I1
(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."
(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))))
projects / sbcl.git / blobdiff