X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=1c8b291e804bfb1664e3b457362e9dd32931cc20;hb=e8d94e7c0f7efc78627e6347d4441f4176e8d160;hp=c0feefe3d25298b7a1b2811cc82c846fa6a6bfa7;hpb=fb9c34275389e23f32d80954ab4848fac48936d9;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index c0feefe..1c8b291 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -15,6 +15,30 @@ (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 @@ -25,7 +49,7 @@ (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)