(in-package "SB-THREAD") ; this is white-box testing, really
+;;; We had appalling scaling properties for a while. Make sure they
+;;; don't reappear.
+(defun scaling-test (function &optional (nthreads 5))
+ "Execute FUNCTION with NTHREADS lurking to slow it down."
+ (let ((queue (sb-thread:make-waitqueue))
+ (mutex (sb-thread:make-mutex)))
+ ;; Start NTHREADS idle threads.
+ (dotimes (i nthreads)
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:condition-wait queue mutex)
+ (sb-ext:quit))))
+ (let ((start-time (get-internal-run-time)))
+ (funcall function)
+ (prog1 (- (get-internal-run-time) start-time)
+ (sb-thread:condition-broadcast queue)))))
+(defun fact (n)
+ "A function that does work with the CPU."
+ (if (zerop n) 1 (* n (fact (1- n)))))
+(let ((work (lambda () (fact 15000))))
+ (let ((zero (scaling-test work 0))
+ (four (scaling-test work 4)))
+ ;; a slightly weak assertion, but good enough for starters.
+ (assert (< four (* 1.5 zero)))))
+
;;; For one of the interupt-thread tests, we want a foreign function
;;; that does not make syscalls
-(setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
-(with-open-file (o "threads-foreign.c" :direction :output)
+(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
(format o "void loop_forever() { while(1) ; }~%"))
(sb-ext:run-program
"cc"
(or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
-(sb-alien:load-1-foreign "threads-foreign.so")
+(sb-alien:load-shared-object "threads-foreign.so")
(sb-alien:define-alien-routine loop-forever sb-alien:void)
;;; elementary "can we get a lock and release it again"
(let ((l (make-mutex :name "foo"))
(p (current-thread-id)))
- (assert (eql (mutex-value l) nil))
- (assert (eql (mutex-lock l) 0))
+ (assert (eql (mutex-value l) nil) nil "1")
+ (assert (eql (mutex-lock l) 0) nil "2")
(sb-thread:get-mutex l)
- (assert (eql (mutex-value l) p))
- (assert (eql (mutex-lock l) 0))
+ (assert (eql (mutex-value l) p) nil "3")
+ (assert (eql (mutex-lock l) 0) nil "4")
(sb-thread:release-mutex l)
- (assert (eql (mutex-value l) nil))
- (assert (eql (mutex-lock l) 0)))
+ (assert (eql (mutex-value l) nil) nil "5")
+ (assert (eql (mutex-lock l) 0) nil "6")
+ (describe l))
+
+;; test that SLEEP actually sleeps for at least the given time, even
+;; if interrupted by another thread exiting/a gc/anything
+(let ((start-time (get-universal-time)))
+ (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
+ (sleep 5)
+ (assert (>= (get-universal-time) (+ 5 start-time))))
+
(let ((queue (make-waitqueue :name "queue"))
(lock (make-mutex :name "lock")))
(condition-notify queue))
(sleep 1)))
+(let ((mutex (make-mutex :name "contended")))
+ (labels ((run ()
+ (let ((me (current-thread-id)))
+ (dotimes (i 100)
+ (with-mutex (mutex)
+ (sleep .1)
+ (assert (eql (mutex-value mutex) me)))
+ (assert (not (eql (mutex-value mutex) me))))
+ (format t "done ~A~%" (current-thread-id)))))
+ (let ((kid1 (make-thread #'run))
+ (kid2 (make-thread #'run)))
+ (format t "contention ~A ~A~%" kid1 kid2))))
(defun test-interrupt (function-to-interrupt &optional quit-p)
(let ((child (make-thread function-to-interrupt)))
(terminate-thread child))
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
+
(let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
;; NB this only works on x86: other ports don't have a symbol for
;; pseudo-atomic atomicity
+ (format t "new thread ~A~%" c)
(dotimes (i 100)
(sleep (random 1d0))
(interrupt-thread c
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
(terminate-thread c))
-;; I'm not sure that this one is always successful. Note race potential:
-;; I haven't checked if decf is atomic here
-(let ((done 2))
- (make-thread (lambda () (dotimes (i 100) (sb-ext:gc)) (decf done)))
- (make-thread (lambda () (dotimes (i 25) (sb-ext:gc :full t)) (decf done)))
+(format t "~&interrupt test done~%")
+
+(let (a-done b-done)
+ (make-thread (lambda ()
+ (dotimes (i 100)
+ (sb-ext:gc) (princ "\\") (force-output) )
+ (setf a-done t)))
+ (make-thread (lambda ()
+ (dotimes (i 25)
+ (sb-ext:gc :full t)
+ (princ "/") (force-output))
+ (setf b-done t)))
(loop
- (when (zerop done) (return))
+ (when (and a-done b-done) (return))
(sleep 1)))
+(format t "~&gc test done~%")
+
+#| ;; a cll post from eric marsden
+| (defun crash ()
+| (setq *debugger-hook*
+| (lambda (condition old-debugger-hook)
+| (debug:backtrace 10)
+| (unix:unix-exit 2)))
+| #+live-dangerously
+| (mp::start-sigalrm-yield)
+| (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
+| (mp:make-process #'roomy)
+| (mp:make-process #'roomy)))
+|#
;; give the other thread time to die before we leave, otherwise the
;; overall exit status is 0, not 104
(sleep 2)
-;(sb-ext:quit :unix-status 104)
+(sb-ext:quit :unix-status 104)