-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques dlists kernel threads continuations math\r
-concurrency.conditions combinators.short-circuit accessors\r
-locals ;\r
-IN: concurrency.locks\r
-\r
-! Simple critical sections\r
-TUPLE: lock threads owner reentrant? ;\r
-\r
-: <lock> ( -- lock )\r
- <dlist> f f lock boa ;\r
-\r
-: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock boa ;\r
-\r
-<PRIVATE\r
-\r
-: acquire-lock ( lock timeout -- )\r
- over owner>>\r
- [ 2dup [ threads>> ] dip "lock" wait ] when drop\r
- self >>owner drop ;\r
-\r
-: release-lock ( lock -- )\r
- f >>owner\r
- threads>> notify-1 ;\r
-\r
-:: do-lock ( lock timeout quot acquire release -- )\r
- lock timeout acquire call\r
- quot lock release curry [ ] cleanup ; inline\r
-\r
-: (with-lock) ( lock timeout quot -- )\r
- [ acquire-lock ] [ release-lock ] do-lock ; inline\r
-\r
-PRIVATE>\r
-\r
-: with-lock-timeout ( lock timeout quot -- )\r
- pick reentrant?>> [\r
- pick owner>> self eq? [\r
- 2nip call\r
- ] [\r
- (with-lock)\r
- ] if\r
- ] [\r
- (with-lock)\r
- ] if ; inline\r
-\r
-: with-lock ( lock quot -- )\r
- f swap with-lock-timeout ; inline\r
-\r
-! Many-reader/single-writer locks\r
-TUPLE: rw-lock readers writers reader# writer ;\r
-\r
-: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock boa ;\r
-\r
-<PRIVATE\r
-\r
-: add-reader ( lock -- )\r
- [ 1 + ] change-reader# drop ;\r
-\r
-: acquire-read-lock ( lock timeout -- )\r
- over writer>>\r
- [ 2dup [ readers>> ] dip "read lock" wait ] when drop\r
- add-reader ;\r
-\r
-: notify-writer ( lock -- )\r
- writers>> notify-1 ;\r
-\r
-: remove-reader ( lock -- )\r
- [ 1 - ] change-reader# drop ;\r
-\r
-: release-read-lock ( lock -- )\r
- dup remove-reader\r
- dup reader#>> zero? [ notify-writer ] [ drop ] if ;\r
-\r
-: acquire-write-lock ( lock timeout -- )\r
- over writer>> pick reader#>> 0 > or\r
- [ 2dup [ writers>> ] dip "write lock" wait ] when drop\r
- self >>writer drop ;\r
-\r
-: release-write-lock ( lock -- )\r
- f >>writer\r
- dup readers>> deque-empty?\r
- [ notify-writer ] [ readers>> notify-all ] if ;\r
-\r
-: reentrant-read-lock-ok? ( lock -- ? )\r
- #! If we already have a write lock, then we can grab a read\r
- #! lock too.\r
- writer>> self eq? ;\r
-\r
-: reentrant-write-lock-ok? ( lock -- ? )\r
- #! The only case where we have a writer and > 1 reader is\r
- #! write -> read re-entrancy, and in this case we prohibit\r
- #! a further write -> read -> write re-entrancy.\r
- { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;\r
-\r
-PRIVATE>\r
-\r
-: with-read-lock-timeout ( lock timeout quot -- )\r
- pick reentrant-read-lock-ok? [\r
- [ drop add-reader ] [ remove-reader ] do-lock\r
- ] [\r
- [ acquire-read-lock ] [ release-read-lock ] do-lock\r
- ] if ; inline\r
-\r
-: with-read-lock ( lock quot -- )\r
- f swap with-read-lock-timeout ; inline\r
-\r
-: with-write-lock-timeout ( lock timeout quot -- )\r
- pick reentrant-write-lock-ok? [ 2nip call ] [\r
- [ acquire-write-lock ] [ release-write-lock ] do-lock\r
- ] if ; inline\r
-\r
-: with-write-lock ( lock quot -- )\r
- f swap with-write-lock-timeout ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: deques dlists kernel threads continuations math
+concurrency.conditions combinators.short-circuit accessors
+locals ;
+IN: concurrency.locks
+
+! Simple critical sections
+TUPLE: lock threads owner reentrant? ;
+
+: <lock> ( -- lock )
+ <dlist> f f lock boa ;
+
+: <reentrant-lock> ( -- lock )
+ <dlist> f t lock boa ;
+
+<PRIVATE
+
+: acquire-lock ( lock timeout -- )
+ over owner>>
+ [ 2dup [ threads>> ] dip "lock" wait ] when drop
+ self >>owner drop ;
+
+: release-lock ( lock -- )
+ f >>owner
+ threads>> notify-1 ;
+
+:: do-lock ( lock timeout quot acquire release -- )
+ lock timeout acquire call
+ quot lock release curry [ ] cleanup ; inline
+
+: (with-lock) ( lock timeout quot -- )
+ [ acquire-lock ] [ release-lock ] do-lock ; inline
+
+PRIVATE>
+
+: with-lock-timeout ( lock timeout quot -- )
+ pick reentrant?>> [
+ pick owner>> self eq? [
+ 2nip call
+ ] [
+ (with-lock)
+ ] if
+ ] [
+ (with-lock)
+ ] if ; inline
+
+: with-lock ( lock quot -- )
+ f swap with-lock-timeout ; inline
+
+! Many-reader/single-writer locks
+TUPLE: rw-lock readers writers reader# writer ;
+
+: <rw-lock> ( -- lock )
+ <dlist> <dlist> 0 f rw-lock boa ;
+
+<PRIVATE
+
+: add-reader ( lock -- )
+ [ 1 + ] change-reader# drop ;
+
+: acquire-read-lock ( lock timeout -- )
+ over writer>>
+ [ 2dup [ readers>> ] dip "read lock" wait ] when drop
+ add-reader ;
+
+: notify-writer ( lock -- )
+ writers>> notify-1 ;
+
+: remove-reader ( lock -- )
+ [ 1 - ] change-reader# drop ;
+
+: release-read-lock ( lock -- )
+ dup remove-reader
+ dup reader#>> zero? [ notify-writer ] [ drop ] if ;
+
+: acquire-write-lock ( lock timeout -- )
+ over writer>> pick reader#>> 0 > or
+ [ 2dup [ writers>> ] dip "write lock" wait ] when drop
+ self >>writer drop ;
+
+: release-write-lock ( lock -- )
+ f >>writer
+ dup readers>> deque-empty?
+ [ notify-writer ] [ readers>> notify-all ] if ;
+
+: reentrant-read-lock-ok? ( lock -- ? )
+ #! If we already have a write lock, then we can grab a read
+ #! lock too.
+ 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.
+ { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
+
+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
+ ] 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
+ ] if ; inline
+
+: with-write-lock ( lock quot -- )
+ f swap with-write-lock-timeout ; inline
projects / factor.git / blobdiff