From 5fdb9edd71a21b3697ba6f407aca270060ef173c Mon Sep 17 00:00:00 2001 From: NIIMI Satoshi Date: Sat, 20 Oct 2007 06:27:20 +0000 Subject: [PATCH 1/1] 1.0.10.51: New function: THREAD-YIELD An interface to sched_yield(). And use it in busy loops in some tests. --- doc/manual/threading.texinfo | 1 + package-data-list.lisp-expr | 1 + src/code/target-thread.lisp | 6 ++++++ src/runtime/thread.c | 10 ++++++++++ tests/clos-add-remove-method.impure.lisp | 4 ++-- tests/clos-cache.impure.lisp | 2 +- tests/threads.impure.lisp | 3 ++- version.lisp-expr | 2 +- 8 files changed, 24 insertions(+), 5 deletions(-) diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 7e84de5..57eaf58 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -43,6 +43,7 @@ threading on Darwin (Mac OS X) and FreeBSD on the x86 is experimental. @include fun-sb-thread-interrupt-thread-error-thread.texinfo @include fun-sb-thread-interrupt-thread.texinfo @include fun-sb-thread-terminate-thread.texinfo +@include fun-sb-thread-thread-yield.texinfo @node Special Variables @comment node-name, next, previous, up diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a74cd99..c93e2c4 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1691,6 +1691,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "INTERRUPT-THREAD-ERROR" "INTERRUPT-THREAD-ERROR-THREAD" "INTERRUPT-THREAD" "TERMINATE-THREAD" "DESTROY-THREAD" + "THREAD-YIELD" "MUTEX" "MAKE-MUTEX" "MUTEX-NAME" "MUTEX-VALUE" "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX" "WITH-RECURSIVE-LOCK" diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 38549a3..b60ce71 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -844,6 +844,12 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (sap-ref-sap thread-sap (* sb!vm:n-word-bytes sb!vm::thread-next-slot))))))) +(define-alien-routine "thread_yield" int) + +#!+sb-doc +(setf (fdocumentation 'thread-yield 'function) + "Yield the processor to other threads.") + #!+sb-thread (defun symbol-value-in-thread (symbol thread-sap) (let* ((index (sb!vm::symbol-tls-index symbol)) diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 9044dfd..d38fd72 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -729,3 +729,13 @@ void gc_start_the_world() FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n")); } #endif + +int +thread_yield() +{ +#ifdef LISP_FEATURE_SB_THREAD + return sched_yield(); +#else + return 0; +#endif +} diff --git a/tests/clos-add-remove-method.impure.lisp b/tests/clos-add-remove-method.impure.lisp index 6d09340..b4ac601 100644 --- a/tests/clos-add-remove-method.impure.lisp +++ b/tests/clos-add-remove-method.impure.lisp @@ -77,12 +77,12 @@ (defvar *run* nil) (defun remove-methods (list) - (loop until *run*) + (loop until *run* do (sb-thread:thread-yield)) (dolist (method list) (remove-method #'foo method))) (defun add-methods (list) - (loop until *run*) + (loop until *run* do (sb-thread:thread-yield)) (dolist (method list) (add-method #'foo method))) diff --git a/tests/clos-cache.impure.lisp b/tests/clos-cache.impure.lisp index 4959a3f..c3e07d6 100644 --- a/tests/clos-cache.impure.lisp +++ b/tests/clos-cache.impure.lisp @@ -65,7 +65,7 @@ (defun test-loop () (note "/~S waiting for permission to run" sb-thread:*current-thread*) - (loop until *run-cache-test*) + (loop until *run-cache-test* do (sb-thread:thread-yield)) (note "/~S joining the thundering herd" sb-thread:*current-thread*) (handler-case (loop repeat 1024 do (test-cache)) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 867f408..c68b615 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -73,7 +73,8 @@ (loop repeat 10 collect (sb-thread:make-thread (lambda () - (loop until run) + (loop until run + do (sb-thread:thread-yield)) (loop repeat n do (,incf x))))))) (setf run t) (dolist (th threads) diff --git a/version.lisp-expr b/version.lisp-expr index 02d1ab1..f1a6863 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.10.50" +"1.0.10.51" -- 1.7.10.4