- bordeaux-threads-devel - mailman3.common-lisp.net

[Bordeaux-threads-devel] thread-join vs join-thread in API
by Jeff Cunningham 02 Aug '11

02 Aug '11

> Hi. > > New to the list. I noticed the Trac API gives the function name as > THREAD-JOIN, which doesn't exist in bordeaux-threads under SBCL. However > JOIN-THREAD does. Should one or the other be changed? > > Regards, > Jeff Cunningham

2 1

[Bordeaux-threads-devel] [Updated]Patch for ABCL against BORDEAUX-THREADS HEAD
by Mark Evenson 07 Apr '11

07 Apr '11

Please consider the [following patch for ABCL against BORDEAUX-THREAD HEAD][1]. The patch provides implementation of both BT locking semantics (recursively head and not) by use of [java.util.concurrent.locks ReentrantLock][2] as well as a (hopefully) correct implementation of POSIX-style condition variable, and allows non-blocking lock acquisition. [1]: http://slack.net/~evenson/abcl/hunchentoot/bordeaux-threads-abcl-20110215a.… [2]; http://download.oracle.com/javase/6/docs/api/java/util/concurrent/locks/Ree… -- "A screaming comes across the sky. It has happened before, but there is nothing to compare to it now."

3 6

[Bordeaux-threads-devel] binding output stream in thread for slime use
by Antony 30 Dec '10

30 Dec '10

Hi I am trying to use bordeaux threads. Trying to figure out how to make output from a thread function appear in slime instead of the lisp terminal. The lisp I am using is Clozure Common Lisp Version 1.6-r14468M (WindowsX8664) I beleive I have the latest bordeaux threads Following is my test code. I hope the intentions are clear. What am I doing wrong or missing? Code follows Thanks, -Antony (asdf:oos 'asdf:load-op :bordeaux-threads) (format t "~%appearing in slime") (defun thread-test () (format t "~%appearing in lisp terminal: ~A" (bordeaux-threads:thread-name (bordeaux-threads:current-thread)))) (let ((bindings '((*standard-input* . *standard-input*) (*standard-output* . *standard-output*) (*query-io* . *query-io*) (*trace-output* . *trace-output*)))) ;;is this correct? (dolist (name '("foo" "bar")) (bordeaux-threads:make-thread #'thread-test :name name :initial-bindings bindings)))

3 3

[Bordeaux-threads-devel] patch for thread-wait
by Faré 14 Dec '10

14 Dec '10

Dear bordeaux-threads developers, I have a patch that adds bt support for thread-wait and thread-wait-with-timeout, modelled after the process-wait and process-wait-with-timeout functions sported by several Lisp APIs. This API should be considered a legacy compatibility API, as these operations may have made sense long ago on timesharing monoprocessors, but are necessarily expensive on multiprocessors. Nevertheless, we had a use for them at ITA, and I threw together this compatibility support, until we get our code cleaned up. Please consider this patch for inclusion, though it has only been lightly tested. PS: I also have a patch to add XCVB support to bordeaux-threads, though you might not be interested. [ François-René ÐVB Rideau | Reflection&Cybernethics | http://fare.tunes.org ] As the Chinese say, 1001 words is worth more than a picture. — John McCarthy

1 0

[Bordeaux-threads-devel] Patch for ABCL against BORDEAUX-THREADS-0.8.0
by Mark Evenson 04 Dec '10

04 Dec '10

ABCL's multithreading symbols have moved to THREADS package (this was deprecated with abcl-0.18 and removed with abcl-0.22). Implement CONDITION-WAIT and CONDITION-NOTIFY for ABCL. Use 10ms pause for ABCL's THREAD-YIELD. -- "A screaming comes across the sky. It has happened before, but there is nothing to compare to it now."

2 2

[Bordeaux-threads-devel] Clarifying some behavior in the documentation
by Vladimir Sedach 01 Dec '10

01 Dec '10

Hello, I've encountered two cases that affect behavior of code but aren't clarified in the documentation: 1. At least one implementation (SBCL) requires that the lock on which condition-wait is called is to be held by the thread that calls condition-notify on the corresponding CV. This should be mentioned in the documentation as a requirement. 2. It is undefined what happens when release-lock is called inside a with-lock-held on the same lock. SBCL and Clozure appear to handle this "properly," although I think the documented behavior should be the same as with regular release-lock ("It is an error to call this unless the lock has previously been acquired (and not released) by the same thread," that is, it should be an error to call release-lock inside a with-lock-held). Thank you, Vladimir

2 3

[Bordeaux-threads-devel] Bordeaux-Threads release 0.8.0
by Stelian Ionescu 02 Oct '10

02 Oct '10

There's a new release of Bordeaux-Threads. Noteworthy changes since 0.7.0: * Various bug fixes for MCL, Lispworks 5&6 and Clisp * Updates for ABCL and ECL * Added type BT:THREAD * Added function BT:START-MULTIPROCESSING * BT:INTERRUPT-THREAD now takes &REST args * Switched test suite to FiveAM -- Stelian Ionescu a.k.a. fe[nl]ix Quidquid latine dictum sit, altum videtur. http://common-lisp.net/project/iolib

1 0

[Bordeaux-threads-devel] *default-special-bindings* docstring in 0-8-8-dev
by james anderson 04 Sep '10

04 Sep '10

re: (defvar *default-special-bindings* nil "This variable holds an alist associating special variable symbols to forms to evaluate. Special variables named in this list will be locally bound in the new thread before it begins executing user code. This variable may be rebound around calls to MAKE-THREAD to add/alter default bindings. The effect of mutating this list is undefined, but earlier forms take precedence over later forms for the same symbol, so defaults may be overridden by consing to the head of the list.") at least for sbcl and clozure, one needs to append to the list. does the spec say something else somewhere? * (progv '(a s a) '(1 2 3) a) ; in: LAMBDA NIL ; (PROGV '(A S A) '(1 2 3) A) ; --> LET UNWIND-PROTECT FLET BLOCK MULTIPLE-VALUE-BIND MULTIPLE- VALUE-CALL ; --> BLOCK SB-C::%WITHIN-CLEANUP RETURN-FROM ; ==> ; (PROGN ; (LABELS ((#:UNBIND1 (SB-C::VARS) ; (DECLARE #) ; (LET # ; #)) ; (#:BIND0 (SB-C::VARS SB-C::VALS) ; (DECLARE #) ; (COND # # #))) ; (#:BIND0 '(A S A) '(1 2 3))) ; NIL ; A) ; ; caught WARNING: ; undefined variable: A ; ; compilation unit finished ; Undefined variable: ; A ; caught 1 WARNING condition 3 *

2 1

[Bordeaux-threads-devel] ECL implementation update
by Kamil Shakirov 23 Aug '10

23 Aug '10

Hi List, The attached patch adds support for condition variables and recursive locks supported by ECL implementation. All test cases now pass with ECL 10.7.1. -- wbr.

2 1

[Bordeaux-threads-devel] Is there a multi-implementation way to get a timeout on condition-notify?
by Matt Lamari 18 Aug '10

18 Aug '10

On lispworks (6) there's condition-notify-with-timeout. On SBCL - not sure - there's a with-timeout that can make a form throw; but a little birdie told me that it's not supported on all platforms. Any good ideas? I've toyed with ideas for emulating it; but they tend to fall down under scrutiny.

1 0

[Bordeaux-threads-devel] [BUG-FIX] Error: Symbol "CONDITION-SIGNAL" not found at all in the MP package.
by Ryan Hope 18 Aug '10

18 Aug '10

I get this error "Error: Symbol "CONDITION-SIGNAL" not found at all in the MP package." using bordeaux-threads from git on Lispworks6. Below is a fix... diff --git a/src/impl-lispworks.lisp b/src/impl-lispworks.lisp index 8c88b30..949e7ff 100644 --- a/src/impl-lispworks.lisp +++ b/src/impl-lispworks.lisp @@ -78,7 +78,7 @@ Distributed under the MIT license (see LICENSE file) #+(or lispworks6) (defun condition-notify (condition-variable) - (mp:condition-signal condition-variable)) + (mp:condition-variable-signal condition-variable)) (defun thread-yield () (mp:process-allow-scheduling)) -- Ryan Hope, M.S. CogWorks Lab Department of Cognitive Science Rensselaer Polytechnic Institute

2 1

[Bordeaux-threads-devel] Docs link dead.
by Robin Lee Powell 11 Jul '10

11 Jul '10

The API documentation link on http://common-lisp.net/project/bordeaux-threads/ is dead, and I can't find a replacement. -Robin -- http://singinst.org/ : Our last, best hope for a fantastic future. Lojban (http://www.lojban.org/) The language in which "this parrot is dead" is "ti poi spitaki cu morsi", but "this sentence is false" is "na nei". My personal page: http://www.digitalkingdom.org/rlp/

2 1

[Bordeaux-threads-devel] Source repository switch to git
by Stelian Ionescu 11 May '10

11 May '10

I've wanted for some time do get rid of darcs, and this is it: the main repository is now http://gitorious.org/bordeaux-threads/bordeaux-threads with a backup at http://common-lisp.net/gitweb?p=projects/bordeaux-threads/bordeaux-threads.… I'll eliminate the darcs repository in a week -- Stelian Ionescu a.k.a. fe[nl]ix Quidquid latine dictum sit, altum videtur. http://common-lisp.net/project/iolib

2 2

[Bordeaux-threads-devel] license verification for inclusion in de.setf.amqp
by james anderson 15 Feb '10

15 Feb '10

good morning; i have released a library, de.setf.amqp[1], which incorporates work of yours. the combined license is the gnu affero. please see the readme[2] for more information. this is to verify the contact information for your library's license. yours is the last respective contact. in some cases, there was none and i have substituted a mailing list as an immediate place-holder, even though, as subscription-only lists, it is not well suited to this purpose. please advise me, should an alternative contact be available. [1] : http://github.com/lisp/de.setf.amqp [2] : http://github.com/lisp/de.setf.amqp/blob/master/README.md

1 0

[Bordeaux-threads-devel] changes for mcl@5.2 (3)
by james anderson 14 Feb '10

14 Feb '10

2 1

[Bordeaux-threads-devel] changes for mcl@5.2
by james anderson 14 Feb '10

14 Feb '10

good afternoon; please find enclosed below a diff relative to patch 162 to improve support for mcl-5.2 + define acquire-lock and release-lock * add dynamic-extent declarations for mcl and ccl ? why repeat the deftype per implementation rather than use satisfies? --- diff -rN old-bordeaux-threads/src/bordeaux-threads.lisp new-bordeaux- threads/src/bordeaux-threads.lisp 110a111,113 > > > (deftype bt:thread () '(satisfies bt:threadp)) diff -rN old-bordeaux-threads/src/impl-clozure.lisp new-bordeaux- threads/src/impl-clozure.lisp 85a86 > (declare (dynamic-extent args)) diff -rN old-bordeaux-threads/src/impl-mcl.lisp new-bordeaux-threads/ src/impl-mcl.lisp 32a33,43 > (defun acquire-lock (lock &optional (wait-p t)) > (if wait-p > (ccl:process-lock lock ccl:*current-process*) > ;; this is broken, but it's better than a no-op > (ccl:without-interrupts > (when (null (ccl::lock.value lock)) > (ccl:process-lock lock ccl:*current-process*))))) > > (defun release-lock (lock) > (ccl:process-unlock lock)) > 44a56 > (declare (dynamic-extent args))

2 1

[Bordeaux-threads-devel] changes for mcl@5.2 (2)
by james anderson 14 Feb '10

14 Feb '10

good afternoon; please find enclosed below a diff relative to patch 162 to improve support for mcl-5.2. apologies for missing the symbol problem in the 0.6 -> 0.7 change + define acquire-lock and release-lock * add dynamic-extent declarations for mcl and ccl * ccl::process is not external ? why repeat the deftype per implementation rather than use satisfies? --- diff -rN old-bordeaux-threads/src/bordeaux-threads.lisp new-bordeaux- threads/src/bordeaux-threads.lisp 110a111,113 > > > (deftype bt:thread () '(satisfies bt:threadp)) diff -rN old-bordeaux-threads/src/impl-clozure.lisp new-bordeaux- threads/src/impl-clozure.lisp 85a86 > (declare (dynamic-extent args)) diff -rN old-bordeaux-threads/src/impl-mcl.lisp new-bordeaux-threads/ src/impl-mcl.lisp 12c12 < 'ccl:process) --- > 'ccl::process) 32a33,43 > (defun acquire-lock (lock &optional (wait-p t)) > (if wait-p > (ccl:process-lock lock ccl:*current-process*) > ;; this is broken, but it's better than a no-op > (ccl:without-interrupts > (when (null (ccl::lock.value lock)) > (ccl:process-lock lock ccl:*current-process*))))) > > (defun release-lock (lock) > (ccl:process-unlock lock)) > 44a56 > (declare (dynamic-extent args))

1 0

[Bordeaux-threads-devel] Bordeaux-threads 0.7->Lispworks support (4, 5 and 6) patch
by Matt Lamari 10 Feb '10

10 Feb '10

Diff is from published 0.7 to a working copy. Lispworks pre-6.0 and 6.0 tested (I tested on 5.1 and 6.0) Added the rest of the API for lispworks. make-recursive-lock and make-lock are now differentiated in LW6 The real differences come in condition support. Pre-6.0 (4 and 5) Lispworks has condition variables emulated via lispworks' old polling lock. Lispworks 6+ condition code just calls through to the new 6.0 condition constructs. Both pass the unit-test, and both notify only a single thread. Please add this to the bordeaux-threads tip and publish. If the format or contents are an impediment please advise so I can correct. Thanks, Matt --- ..\bordeaux-threads_new\bordeaux-threads.asd 2009-12-24 19:35:44.000000000 -0600 +++ bordeaux-threads.asd 2009-12-29 23:21:40.637166200 -0600 @@ -53,7 +53,8 @@ #-thread-support "unsupported") (:file "default-implementations") #+(and thread-support - (or armedbear digitool ecl lispworks)) + (or armedbear digitool ecl) + (not lispworks)) (:file "condition-variables")))) :in-order-to ((test-op (load-op bordeaux-threads-test))) :perform (test-op :after (op c) --- c:\t\impl-lispworks.lisp 2009-12-24 19:35:44.000000000 -0600 +++ impl-lispworks.lisp 2010-02-03 18:07:37.851838700 -0600 @@ -11,7 +11,7 @@ ;;; documentation on the LispWorks Multiprocessing interface can be found at ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm -(mp:initialize-multiprocessing) +; (mp:initialize-multiprocessing) ; Had to comment this out as it would block deployment running ;;; Thread Creation @@ -29,8 +29,15 @@ ;;; Resource contention: locks and recursive locks +(defun make-recursive-lock (&optional name) + (mp:make-lock :name (or name "Anonymous lock requested as recursive") + #-(or lispworks4 lispworks5) :recursivep + #-(or lispworks4 lispworks5) t)) + (defun make-lock (&optional name) - (mp:make-lock :name (or name "Anonymous lock"))) + (mp:make-lock :name (or name "Anonymous lock") + #-(or lispworks4 lispworks5) :recursivep + #-(or lispworks4 lispworks5) nil)) (defun acquire-lock (lock &optional (wait-p t)) (mp:process-lock lock nil @@ -38,12 +45,21 @@ ((numberp wait-p) wait-p) (t nil)))) +(defun acquire-recursive-lock (&rest rest) + (apply #'acquire-lock rest)) + (defun release-lock (lock) (mp:process-unlock lock)) +(defun release-recursive-lock (lock) + (release-lock lock)) + (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) +(defmacro with-recursive-lock-held (&rest rest) + `(with-lock-held ,@rest)) + ;;; Resource contention: condition variables (defun thread-yield () @@ -68,4 +84,216 @@ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread)) + + + +#+(or lispworks4 lispworks5) +(progn +; Lispworks 4 and 5 condition support is simulated, albeit via a lightweight wrapper over +; its own polling-based wait primitive. Waiters register with the condition variable, +; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval. +; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm +; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup +; on every poll (or have to serialize on the condition variable) and a mechanism is put +; in place to unregister any waiter that exits wait for other reasons, +; and to resend any (single) notification that may have been consumed before this (corner +; case). Much of the complexity present is to support single notification (as recommended in +; the spec); but a distinct condition-notify-all is provided for reference. +; Single-notification follows a first-in first-out ordering +; +; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least +; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager. +; While not true zero like a true native solution, the use of the Lispworks native checks appear +; fast enough to be an equivalent substitute (thread count will cause issue before the +; waiting overhead becomes significant) +(defstruct (condition-variable (:constructor make-lw-condition (name))) + name + (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t) + (wait-tlist (cons nil nil) :type cons :read-only t) + (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t) + ; unconsumed-notifications is to track :remove-from-consideration + ; for entries that may have exited prematurely - notification is sent through + ; to someone else, and offender is removed from hash and list + (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t)) + +(defun make-condition-variable (&key name) + (make-lw-condition name)) + +(defmacro with-cv-access (condition-variable &body body) + (let ((cv-sym (gensym)) + (slots '(lock wait-tlist wait-hash unconsumed-notifications))) + `(let ((,cv-sym ,condition-variable)) + (with-slots ,slots + ,cv-sym + (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body))) + (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore + ,@body))))) + +(defmacro defcvfun (function-name (condition-variable &rest args) &body body) + `(defun ,function-name (,condition-variable ,@args) + (with-cv-access ,condition-variable + ,@body))) +#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun + +; utility function thath assumes process is locked on condition-variable's lock. +(defcvfun do-notify-single (condition-variable) ; assumes already locked + (let ((id (caar wait-tlist))) + (when id + (pop (car wait-tlist)) + (unless (car wait-tlist) ; check for empty + (setf (cdr wait-tlist) nil)) + (funcall (gethash id wait-hash)) ; call waiter-wakeup + (remhash id wait-hash) ; absence of entry = permission to proceed + (setf (gethash id unconsumed-notifications) t)))) + +; Added for completeness/to show how it's done in this paradigm; but +; The symbol for this call is not exposed in the api +(defcvfun condition-notify-all (condition-variable) + (locked + (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup)) + (clrhash wait-hash) + (clrhash unconsumed-notifications) ; don't care as everyone just got notified + (setf (car wait-tlist) nil) + (setf (cdr wait-tlist) nil))) + +; Currently implemented so as to notify only one waiting thread +(defcvfun condition-notify (condition-variable) + (locked (do-notify-single condition-variable))) + + + +(defun delete-from-tlist (tlist element) + (let ((deleter + (lambda () + (setf (car tlist) (cdar tlist)) + (unless (car tlist) + (setf (cdr tlist) nil))))) + (loop for cons in (car tlist) do + (if (eq element (car cons)) + (progn + (funcall deleter) + (return nil)) + (let ((cons cons)) + (setq deleter + (lambda () + (setf (cdr cons) (cddr cons)) + (unless (cdr cons) + (setf (cdr tlist) cons))))))))) + +(defun add-to-tlist-tail (tlist element) + (let ((new-link (cons element nil))) + (cond + ((car tlist) + (setf (cddr tlist) new-link) + (setf (cdr tlist) new-link)) + (t + (setf (car tlist) new-link) + (setf (cdr tlist) new-link))))) + +(defcvfun condition-wait (condition-variable lock-) + (mp:process-unlock lock-) + (unwind-protect ; for the re-taking of the lock. Guarding all of the code + (let ((wakeup-allowed-to-proceed nil) + (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait"))) + ; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and + ; search the hashtable. That it is locked is for safety/completeness, although + ; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is + ; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became + ; non-atomic in its assigments + (let ((id (cons nil nil)) + (clean-exit nil)) + (locked + (add-to-tlist-tail wait-tlist id) + (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t))))) + (unwind-protect + (progn + (mp:process-wait + "Waiting for notification" + (lambda () + (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed) + (locked (not (gethash id wait-hash)))))) + (locked (remhash id unconsumed-notifications)) + (setq clean-exit t)) ; Notification was consumed + ; Have to call remove-from-consideration just in case process was interrupted + ; rather than having condition met + (unless clean-exit ; clean-exit is just an optimization + (locked + (when (gethash id wait-hash) ; not notified - must have been interrupted + ; Have to unsubscribe + (remhash id wait-hash) + (delete-from-tlist wait-tlist id)) + ; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification! + (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification + (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter + (do-notify-single condition-variable))))))) + (mp:process-lock lock-))) +) + +#-(or lispworks4 lispworks5) +(progn ; LW6+ version + +(defun make-condition-variable (&key name) + (mp:make-condition-variable :name name)) + +(defun condition-wait (condition-variable lock) + (mp:condition-variable-wait condition-variable lock)) + +(defun condition-notify (condition-variable) ; notifies single + (mp:condition-variable-signal condition-variable)) + +) + +; Generally safe sanity check for the locks and single-notify +(defun unit-test-lw-conditions () + (let ((condition-variable (make-condition-variable :name "Test")) + (test-lock (make-lock)) + (completed nil)) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed) (condition-notify condition-variable)))))) + (sleep 2) + (if completed + (print "Failed: Premature passage through condition-wait") + (print "Successfully waited on condition")) + (condition-notify condition-variable) + (sleep 2) + (if (and completed (eql (length completed) 6) (equal (sort completed #'<) (loop for id from 0 to 5 collect id))) + (print "Success: All elements notified") + (print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed))) + + #+(or lispworks4 lispworks5) + (with-cv-access condition-variable + (if (and + (not (or (car wait-tlist) (cdr wait-tlist))) + (zerop (hash-table-count wait-hash)) + (zerop (hash-table-count unconsumed-notifications))) + (print "Success: condition variable restored to initial state") + (print "Error: condition variable retains residue from completed waiters"))) + + (setq completed nil) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed)))))) + (sleep 2) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 1) + (print "Success: Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Notify-single restarted ~A items" (length completed)))) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 2) + (print "Success: second Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Two Notify-singles restarted ~A items" (length completed)))) + (print "shutting down test") + (loop while (with-lock-held (test-lock) (not (= (length completed) 6))) do + (progn + (condition-notify condition-variable) + (sleep 0))) + (loop for i from 0 to 5 do (condition-notify condition-variable)) + (print "Note: In the case of any failures, assume there are outstanding waiting threads") + (values))) + + + (mark-supported)

3 4

[Bordeaux-threads-devel] the way sb-thread:get-mutex is called
by Attila Lendvai 08 Feb '10

08 Feb '10

...and while we are at acquire-lock, the docstring of sb-thread:get-mutex says that without-interrupts is necessary to be around the call to sb-thread:get-mutex. -- attila

1 0

[Bordeaux-threads-devel] bug around unimplemented functions
by Attila Lendvai 08 Feb '10

08 Feb '10

i've told this to Stelian on IRC, just making sure it gets the record: (bt:acquire-recursive-lock nil) simply returns T on sbcl. a quick glance suggests that unimplemented functions are simply noop (instead of an error i guess). -- attila

1 0

[Bordeaux-threads-devel] Having trougle with SBCL 1.0.20 on x86
by Yarek Kowalik 23 Jan '10

23 Jan '10

I get this error when compiling bordeaux-threads, has anyone seen this? Any workarounds? Thanks!! Yarek The value #<SB-KERNEL:DEFSTRUCT-DESCRIPTION CONDITION> is not of type SB-KERNEL:CLASSOID. [Condition of type TYPE-ERROR] Restarts: 0: [TRY-RECOMPILING] Try recompiling impl-sbcl 1: [RETRY] Retry performing #<ASDF:COMPILE-OP NIL {C751441}> on #<ASDF:CL-SOURCE-FILE "impl-sbcl" {C72B119}>. 2: [ACCEPT] Continue, treating #<ASDF:COMPILE-OP NIL {C751441}> on #<ASDF:CL-SOURCE-FILE "impl-sbcl" {C72B119}> as having been successful. 3: [RETRY] Retry SLIME REPL evaluation request. 4: [ABORT] Return to SLIME's top level. 5: [TERMINATE-THREAD] Terminate this thread (#<THREAD "repl-thread" RUNNING {B0580D1}>) Backtrace: 0: (SB-KERNEL:UNDEFINE-STRUCTURE #<SB-KERNEL:DEFSTRUCT-DESCRIPTION CONDITION>) 1: (SB-IMPL::%COMPILER-DEFTYPE TIMEOUT #<FUNCTION (LAMBDA #) {C07AA85}> NIL) 2: (SB-INT:SIMPLE-EVAL-IN-LEXENV ..) 3: ((FLET SB-C::DEFAULT-PROCESSOR) ..) 4: (SB-C::PROCESS-TOPLEVEL-FORM ..) 5: (SB-C::PROCESS-TOPLEVEL-PROGN ..) 6: (SB-C::PROCESS-TOPLEVEL-FORM (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (SB-IMPL::%COMPILER-DEFTYPE 'TIMEOUT (LAMBDA # #))) (SB-C::ORIGINAL-SOURCE-START 0 16) NIL) 7: ((FLET SB-C::DEFAULT-PROCESSOR) (DEFTYPE TIMEOUT () 'SB-EXT:TIMEOUT)) 8: (SB-C::PROCESS-TOPLEVEL-FORM (DEFTYPE TIMEOUT () 'SB-EXT:TIMEOUT) (SB-C::ORIGINAL-SOURCE-START 0 16) NIL) 9: (SB-C::SUB-SUB-COMPILE-FILE #<SB-C::SOURCE-INFO >) 10: ((LAMBDA ())) 11: (SB-C::%WITH-COMPILATION-UNIT #<CLOSURE (LAMBDA #) {BEA6FA5}>)[:EXTERNAL] 12: (SB-C::SUB-COMPILE-FILE #<SB-C::SOURCE-INFO >) 13: (COMPILE-FILE #P"/home/yarek/.sbcl/site/bordeaux-threads_darcs/src/impl-sbcl.lisp")[:EXTERNAL] 14: ((SB-PCL::FAST-METHOD ASDF:PERFORM (ASDF:COMPILE-OP ASDF:CL-SOURCE-FILE)) #<unavailable argument> #<unavailable argument> #<ASDF:COMPILE-OP NIL {C751441}> #<ASDF:CL-SOURCE-FILE "impl-sbcl" {C72B119}>) 15: ((LAMBDA (SB-PCL::.PV. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB-PCL::.ARG1.)) ..) 16: ((SB-PCL::FAST-METHOD ASDF:PERFORM :AROUND (ASDF:COMPILE-OP ASDF:CL-SOURCE-FILE)) ..) 17: ((LAMBDA ())) 18: ((FLET SB-THREAD::WITH-RECURSIVE-LOCK-THUNK)) 19: ((FLET #:WITHOUT-INTERRUPTS-BODY-[CALL-WITH-RECURSIVE-LOCK]508)) 20: (SB-THREAD::CALL-WITH-RECURSIVE-LOCK ..) Locals: SB-DEBUG::ARG-0 = #<CLOSURE (FLET SB-THREAD::WITH-RECURSIVE-LOCK-THUNK) {B68969AD}> SB-DEBUG::ARG-1 = #S(SB-THREAD:MUTEX ..) 21: (SB-C::%WITH-COMPILATION-UNIT #<CLOSURE (LAMBDA #) {BE9601D}>)[:EXTERNAL] 22: (ASDF:OPERATE ASDF:LOAD-OP :FASHION-ORIGAMI)[:EXTERNAL] 23: (SB-INT:SIMPLE-EVAL-IN-LEXENV (ASDF:OOS 'ASDF:LOAD-OP :FASHION-ORIGAMI) #<NULL-LEXENV>) 24: (SWANK::EVAL-REGION "(asdf:oos 'asdf:load-op :fashion-origami)\n") 25: ((LAMBDA ())) 26: (SWANK::TRACK-PACKAGE #<CLOSURE (LAMBDA #) {BEE07AD}>) 27: (SWANK::CALL-WITH-RETRY-RESTART "Retry SLIME REPL evaluation request." #<CLOSURE (LAMBDA #) {BEE073D}>) 28: (SWANK::CALL-WITH-BUFFER-SYNTAX NIL #<CLOSURE (LAMBDA #) {BEE0725}>) 29: (SWANK::REPL-EVAL "(asdf:oos 'asdf:load-op :fashion-origami)\n") 30: (SB-INT:SIMPLE-EVAL-IN-LEXENV (SWANK:LISTENER-EVAL "(asdf:oos 'asdf:load-op :fashion-origami)\n") #<NULL-LEXENV>) 31: (SWANK::EVAL-FOR-EMACS (SWANK:LISTENER-EVAL "(asdf:oos 'asdf:load-op :fashion-origami)\n") "FASHION-ORIGAMI" 439) 32: (SWANK::PROCESS-REQUESTS NIL) 33: ((LAMBDA ())) 34: ((LAMBDA (SWANK-BACKEND::HOOK SWANK-BACKEND::FUN)) #<FUNCTION SWANK:SWANK-DEBUGGER-HOOK> #<CLOSURE (LAMBDA #) {B05A0BD}>) 35: (SWANK::CALL-WITH-REDIRECTED-IO #<SWANK::CONNECTION {AF509A9}> #<CLOSURE (LAMBDA #) {B05A0CD}>) 36: (SWANK::CALL-WITH-CONNECTION #<SWANK::CONNECTION {AF509A9}> #<CLOSURE (LAMBDA #) {B05A0BD}>) 37: (SWANK::HANDLE-REQUESTS #<SWANK::CONNECTION {AF509A9}> NIL) 38: (SWANK::CALL-WITH-BINDINGS NIL #<CLOSURE (LAMBDA #) {B05A095}>) 39: ((FLET SB-THREAD::WITH-MUTEX-THUNK)) 40: ((FLET #:WITHOUT-INTERRUPTS-BODY-[CALL-WITH-MUTEX]477)) 41: (SB-THREAD::CALL-WITH-MUTEX ..) 42: ((LAMBDA ())) 43: ("foreign function: call_into_lisp") 44: ("foreign function: funcall0") 45: ("foreign function: new_thread_trampoline") 46: ("foreign function: #xB7FB880E")

2 4

[Bordeaux-threads-devel] MCL patch
by Chun Tian (binghe) 20 Jan '10

20 Jan '10

Hi, Bordeaux team I found two typos in MCL support. Without them, your package cannot be compiled correctly in MCL (test with RMCL 5.2.1). Please check and merge it. Regards, Chun Tian (binghe)

2 1

[Bordeaux-threads-devel] asdf installation
by Liron Greenstein 10 Jan '10

10 Jan '10

Hey, This is pretty dumb but I'm trying to install hunchentoot via asdf, which depends on bordeaux-threads, and when this installer goes to download bordeaux-threads, it's looking for this .asc PGP signature file at http://common-lisp.net/project/bordeaux-threads/releases/bordeaux-threads.t… failing (you can see why, there's a version number in that file now). I don't know enough about how asdf works to fix this, but could you symlink the file it looks for to the devhead one? Should be fine to do this since it's already blindly downloading bordeaux-threads.tgz anyway so it'll always be devhead. Thanks, Liron

2 1

[Bordeaux-threads-devel] Lispworks Condition-notify - for the latest Bordeaux-threads - please add it to the tip
by Matt Lamari 30 Dec '09

30 Dec '09

We had a conversation on this a while back. Same code (as we discussed), diffed against the latest. The unit-test still passes. ASD file has to be modded to remove a clash with the default condition-var struct Attached are the diff files - I hope they are in the right form. I'd like to get this code out there - please let me know if any changes are required. --- ..\bordeaux-threads_new\bordeaux-threads.asd 2009-12-24 19:35:44.000000000 -0600 +++ bordeaux-threads.asd 2009-12-29 23:21:40.637166200 -0600 @@ -53,7 +53,8 @@ #-thread-support "unsupported") (:file "default-implementations") #+(and thread-support - (or armedbear digitool ecl lispworks)) + (or armedbear digitool ecl) + (not lispworks)) (:file "condition-variables")))) :in-order-to ((test-op (load-op bordeaux-threads-test))) :perform (test-op :after (op c) --- ..\bordeaux-threads_new\src\impl-lispworks.lisp 2009-12-24 19:35:44.000000000 -0600 +++ src\impl-lispworks.lisp 2009-12-29 23:09:54.381383200 -0600 @@ -68,4 +68,191 @@ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread)) + + + + +; Lispworks condition support is simulated, albeit via a lightweight wrapper over +; its own polling-based wait primitive. Waiters register with the condition variable, +; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval. +; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm +; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup +; on every poll (or have to serialize on the condition variable) and a mechanism is put +; in place to unregister any waiter that exits wait for other reasons, +; and to resend any (single) notification that may have been consumed before this (corner +; case). Much of the complexity present is to support single notification (as recommended in +; the spec); but a distinct condition-notify-all is provided for reference. +; Single-notification follows a first-in first-out ordering +; +; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least +; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager. +; While not true zero like a true native solution, the use of the Lispworks native checks appear +; fast enough to be an equivalent substitute (thread count will cause issue before the +; waiting overhead becomes significant) +(defstruct condition-variable + (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t) + (wait-tlist (cons nil nil) :type cons :read-only t) + (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t) + ; unconsumed-notifications is to track :remove-from-consideration + ; for entries that may have exited prematurely - notification is sent through + ; to someone else, and offender is removed from hash and list + (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t)) +; make-condition-variable the default constructor for condition-variable + +(defmacro with-cv-access (condition-variable &body body) + (let ((cv-sym (gensym)) + (slots '(lock wait-tlist wait-hash unconsumed-notifications))) + `(let ((,cv-sym ,condition-variable)) + (with-slots ,slots + ,cv-sym + (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body))) + (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore + ,@body))))) + +(defmacro defcvfun (function-name (condition-variable &rest args) &body body) + `(defun ,function-name (,condition-variable ,@args) + (with-cv-access ,condition-variable + ,@body))) +#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun + +; utility function thath assumes process is locked on condition-variable's lock. +(defcvfun do-notify-single (condition-variable) ; assumes already locked + (let ((id (caar wait-tlist))) + (when id + (pop (car wait-tlist)) + (unless (car wait-tlist) ; check for empty + (setf (cdr wait-tlist) nil)) + (funcall (gethash id wait-hash)) ; call waiter-wakeup + (remhash id wait-hash) ; absence of entry = permission to proceed + (setf (gethash id unconsumed-notifications) t)))) + +; Added for completeness/to show how it's done in this paradigm; but +; The symbol for this call is not exposed in the api +(defcvfun condition-notify-all (condition-variable) + (locked + (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup)) + (clrhash wait-hash) + (clrhash unconsumed-notifications) ; don't care as everyone just got notified + (setf (car wait-tlist) nil) + (setf (cdr wait-tlist) nil))) + +; Currently implemented so as to notify only one waiting thread +(defcvfun condition-notify (condition-variable) + (locked (do-notify-single condition-variable))) + + + +(defun delete-from-tlist (tlist element) + (let ((deleter + (lambda () + (setf (car tlist) (cdar tlist)) + (unless (car tlist) + (setf (cdr tlist) nil))))) + (loop for cons in (car tlist) do + (if (eq element (car cons)) + (progn + (funcall deleter) + (return nil)) + (let ((cons cons)) + (setq deleter + (lambda () + (setf (cdr cons) (cddr cons)) + (unless (cdr cons) + (setf (cdr tlist) cons))))))))) + +(defun add-to-tlist-tail (tlist element) + (let ((new-link (cons element nil))) + (cond + ((car tlist) + (setf (cddr tlist) new-link) + (setf (cdr tlist) new-link)) + (t + (setf (car tlist) new-link) + (setf (cdr tlist) new-link))))) + +(defcvfun condition-wait (condition-variable lock-) + (mp:process-unlock lock-) + (unwind-protect ; for the re-taking of the lock. Guarding all of the code + (let ((wakeup-allowed-to-proceed nil) + (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait"))) + ; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and + ; search the hashtable. That it is locked is for safety/completeness, although + ; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is + ; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became + ; non-atomic in its assigments + (let ((id (cons nil nil)) + (clean-exit nil)) + (locked + (add-to-tlist-tail wait-tlist id) + (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t))))) + (unwind-protect + (progn + (mp:process-wait + "Waiting for notification" + (lambda () + (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed) + (locked (not (gethash id wait-hash)))))) + (locked (remhash id unconsumed-notifications)) + (setq clean-exit t)) ; Notification was consumed + ; Have to call remove-from-consideration just in case process was interrupted + ; rather than having condition met + (unless clean-exit ; clean-exit is just an optimization + (locked + (when (gethash id wait-hash) ; not notified - must have been interrupted + ; Have to unsubscribe + (remhash id wait-hash) + (delete-from-tlist wait-tlist id)) + ; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification! + (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification + (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter + (do-notify-single condition-variable))))))) + (mp:process-lock lock-))) + + +; Generally safe sanity check for the locks and single-notify +(defun unit-test-lw-conditions () + (let ((condition-variable (make-condition-variable)) + (test-lock (make-lock)) + (completed nil)) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed) (condition-notify condition-variable)))))) + (sleep 2) + (if completed + (print "Failed: Premature passage through condition-wait") + (print "Successfully waited on condition")) + (condition-notify condition-variable) + (sleep 2) + (if (and completed (eql (length completed) 6) (equal (sort completed #'<) (loop for id from 0 to 5 collect id))) + (print "Success: All elements notified") + (print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed))) + (with-cv-access condition-variable + (if (and + (not (or (car wait-tlist) (cdr wait-tlist))) + (zerop (hash-table-count wait-hash)) + (zerop (hash-table-count unconsumed-notifications))) + (print "Success: condition variable restored to initial state") + (print "Error: condition variable retains residue from completed waiters"))) + + (setq completed nil) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed)))))) + (sleep 2) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 1) + (print "Success: Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Notify-single restarted ~A items" (length completed)))) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 2) + (print "Success: second Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Two Notify-singles restarted ~A items" (length completed)))) + (loop for i from 0 to 5 do (condition-notify condition-variable)) + (print "Note: In the case of any failures, assume there are outstanding waiting threads") + (values))) + + + (mark-supported)

1 1

[Bordeaux-threads-devel] Version 0.7.0 released
by Stelian Ionescu 25 Dec '09

25 Dec '09

I've just released version 0.7.0 Significant changes since last release: * new function JOIN-THREAD * MAKE-CONDITION-VARIABLE now takes a keyword argument NAME * *default-special-bindings* now contains an alist mapping symbols to forms to be evaluated rather than closures to be funcalled * added *standard-io-bindings* * support for Clisp and Scieneer Common Lisp * nickname "threads" was removed because used by Clisp * dependency on Alexandria(http://common-lisp.net/project/alexandria) -- Stelian Ionescu a.k.a. fe[nl]ix Quidquid latine dictum sit, altum videtur. http://common-lisp.net/project/iolib

1 0