Fix R/W locks

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 }

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

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#
+    dup remove-reader
-    zero? [ notify-writer ] [ drop ] if ;
+    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' -- )
+: reentrant-read-lock-ok? ( lock -- ? )
-    >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline
+    #! 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