From fea927b343291554eacdcaff3bb8a96620bc3560 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 1 Mar 2008 01:57:34 -0600
Subject: [PATCH] Fix R/W locks
---
extra/concurrency/locks/locks-docs.factor | 2 +-
extra/concurrency/locks/locks-tests.factor | 35 ++++++++++++++++++++++
extra/concurrency/locks/locks.factor | 35 ++++++++++++++++------
3 files changed, 62 insertions(+), 10 deletions(-)
diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor
index 86db5914c9..3a89af5ba0 100755
--- a/extra/concurrency/locks/locks-docs.factor
+++ b/extra/concurrency/locks/locks-docs.factor
@@ -46,7 +46,7 @@ $nl
$nl
"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
$nl
-"Read/write locks are reentrant. A thread holding a read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, however a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
+"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
{ $subsection rw-lock }
{ $subsection <rw-lock> }
{ $subsection with-read-lock }
diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor
index 92f1a9f103..806fad6c32 100755
--- a/extra/concurrency/locks/locks-tests.factor
+++ b/extra/concurrency/locks/locks-tests.factor
@@ -176,3 +176,38 @@ threads sequences calendar ;
[ lock-timeout-test ] [
linked-error-thread thread-name "Lock timeout-er" =
] must-fail-with
+
+:: read/write-test ( -- )
+ [let | l [ <lock> ] |
+ [
+ l [ 1 seconds sleep ] with-lock
+ ] "Lock holder" spawn drop
+
+ [
+ l 1/10 seconds [ ] with-lock-timeout
+ ] "Lock timeout-er" spawn-linked drop
+
+ receive
+ ] ;
+
+[
+ <rw-lock> dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+] must-fail
+
+[
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] must-fail
+
+[ ] [
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-read-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] unit-test
diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor
index ea442612b1..43f22c00da 100755
--- a/extra/concurrency/locks/locks.factor
+++ b/extra/concurrency/locks/locks.factor
@@ -55,17 +55,23 @@ TUPLE: rw-lock readers writers reader# writer ;
<PRIVATE
+: add-reader ( lock -- )
+ dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
+
: acquire-read-lock ( lock timeout -- )
over rw-lock-writer
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
- dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
+ add-reader ;
: notify-writer ( lock -- )
rw-lock-writers notify-1 ;
+: remove-reader ( lock -- )
+ dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
+
: release-read-lock ( lock -- )
- dup rw-lock-reader# 1- dup pick set-rw-lock-reader#
- zero? [ notify-writer ] [ drop ] if ;
+ dup remove-reader
+ dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
over rw-lock-writer pick rw-lock-reader# 0 > or
@@ -77,23 +83,34 @@ TUPLE: rw-lock readers writers reader# writer ;
dup rw-lock-readers dlist-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ;
-: do-reentrant-rw-lock ( lock timeout quot quot' -- )
- >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline
+: reentrant-read-lock-ok? ( lock -- ? )
+ #! If we already have a write lock, then we can grab a read
+ #! lock too.
+ rw-lock-writer self eq? ;
+
+: reentrant-write-lock-ok? ( lock -- ? )
+ #! The only case where we have a writer and > 1 reader is
+ #! write -> read re-entrancy, and in this case we prohibit
+ #! a further write -> read -> write re-entrancy.
+ dup rw-lock-writer self eq?
+ swap rw-lock-reader# zero? and ;
PRIVATE>
: with-read-lock-timeout ( lock timeout quot -- )
- [
+ pick reentrant-read-lock-ok? [
+ [ drop add-reader ] [ remove-reader ] do-lock
+ ] [
[ acquire-read-lock ] [ release-read-lock ] do-lock
- ] do-reentrant-rw-lock ; inline
+ ] if ; inline
: with-read-lock ( lock quot -- )
f swap with-read-lock-timeout ; inline
: with-write-lock-timeout ( lock timeout quot -- )
- [
+ pick reentrant-write-lock-ok? [ 2nip call ] [
[ acquire-write-lock ] [ release-write-lock ] do-lock
- ] do-reentrant-rw-lock ; inline
+ ] if ; inline
: with-write-lock ( lock quot -- )
f swap with-write-lock-timeout ; inline