For master: add with-thread-mutex-try-lock

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9ceeeb10161bc33ea573d2971306efd3ee3b042c..3c4b9d12b710d863e3dc11acb0472483981a8707 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5084,6 +5084,7 @@ USA.
          with-thread-events-blocked
          with-thread-mutex-lock
          with-thread-mutex-locked
+         with-thread-mutex-try-lock
          with-thread-mutex-unlocked
          with-thread-timer-stopped
          (without-interruption with-thread-events-blocked)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 71ecfe30f8823a2fabef563aae049b31c784b016..968eb606535207bf567fca5e5b1575b88f2295b4 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -1392,6 +1392,17 @@ USA.
                thunk
                (lambda () (lock-thread-mutex mutex))))
 
+(define (with-thread-mutex-try-lock mutex locked not-locked)
+  (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-TRY-LOCK)
+  (let ((locked?))
+    (dynamic-wind (lambda ()
+                   (set! locked? (try-lock-thread-mutex mutex)))
+                 (lambda ()
+                   (if locked? (locked) (not-locked)))
+                 (lambda ()
+                   (if locked? (unlock-thread-mutex mutex))
+                   (set! locked?)))))
+
 ;;; WITH-THREAD-MUTEX-LOCKED is retained for compatibility for old
 ;;; programs that require recursion.  For new programs, better to
 ;;; refactor into clearer invariants that do not require recursion if