mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
22d7ce133b
Bypassing the emulation layer speeds up lisp mutexes by 2x or more and removes quite a bit of dubious code. WaitOnAddress has been present since Windows 8 (ca. 2012). Fallback to non-futex code if the OS is too old.
61 lines
2.5 KiB
Common Lisp
61 lines
2.5 KiB
Common Lisp
(use-package "SB-THREAD")
|
|
|
|
;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
|
|
;; before entering WITHOUT-INTERRUPTS. When a thread which was
|
|
;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
|
|
;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
|
|
;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
|
|
;; interrupting code thus made a recursive lock attempt.
|
|
|
|
;; This test runs excruciatingly slowly on win32 without futexes.
|
|
;; Using n-threads = 100 with sb-futex, each trial took between .1 and .2
|
|
;; seconds, so 200 trials took ~ 30 seconds.
|
|
;; Without sb-futex and that same number of threads, each trial took
|
|
;; between 1.5 and 2.5 seconds which would be 400 seconds total.
|
|
(defparameter *test-params* (or #+(and win32 (not sb-futex)) '(10 . 20)
|
|
'(100 . 100)))
|
|
|
|
(with-test (:name (:timer :dispatch-thread :make-thread :bug-1180102)
|
|
:skipped-on (not :sb-thread))
|
|
(flet ((test (thread)
|
|
(let ((timer (make-timer (lambda ()) :thread thread)))
|
|
(schedule-timer timer .01 :repeat-interval 0.1)
|
|
(dotimes (i (car *test-params*))
|
|
(let ((threads '())
|
|
(start (get-internal-real-time)))
|
|
(declare (ignorable start))
|
|
(dotimes (i (cdr *test-params*))
|
|
(push (sb-thread:make-thread (lambda () (sleep .01)))
|
|
threads))
|
|
(mapc #'sb-thread:join-thread threads)
|
|
#+nil (format t "Trial ~d: ~f sec~%" i
|
|
(/ (- (get-internal-real-time) start)
|
|
internal-time-units-per-second))))
|
|
(unschedule-timer timer))))
|
|
(test t)
|
|
(test sb-thread:*current-thread*)))
|
|
|
|
(with-test (:name (:make-thread :interrupt-with :make-thread :bug-1180102)
|
|
:skipped-on (not :sb-thread)
|
|
:broken-on :sb-safepoint)
|
|
(fresh-line)
|
|
(write-string "; ")
|
|
(force-output)
|
|
(dotimes (i 100)
|
|
(let (outer-threads
|
|
(inner-threads (list nil))
|
|
(parent *current-thread*))
|
|
(dotimes (i 100)
|
|
(push (make-thread
|
|
(lambda ()
|
|
(interrupt-thread
|
|
parent
|
|
(lambda () (atomic-push (make-thread (lambda ()))
|
|
(car inner-threads))))))
|
|
outer-threads)
|
|
(push (make-thread (lambda ())) outer-threads))
|
|
(mapc #'join-thread outer-threads)
|
|
(mapc #'join-thread (car inner-threads)))
|
|
(write-char #\.)
|
|
(force-output)))
|