1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: deques dlists kernel threads continuations math
4 concurrency.conditions combinators.short-circuit accessors
8 ! Simple critical sections
9 TUPLE: lock threads owner reentrant? ;
12 <dlist> f f lock boa ;
14 : <reentrant-lock> ( -- lock )
15 <dlist> f t lock boa ;
19 : acquire-lock ( lock timeout -- )
21 [ 2dup [ threads>> ] dip "lock" wait ] when drop
24 : release-lock ( lock -- )
28 :: do-lock ( lock timeout quot acquire release -- )
29 lock timeout acquire call
30 quot lock release curry [ ] cleanup ; inline
32 : (with-lock) ( lock timeout quot -- )
33 [ acquire-lock ] [ release-lock ] do-lock ; inline
37 : with-lock-timeout ( lock timeout quot -- )
39 pick owner>> self eq? [
48 : with-lock ( lock quot -- )
49 f swap with-lock-timeout ; inline
51 ! Many-reader/single-writer locks
52 TUPLE: rw-lock readers writers reader# writer ;
54 : <rw-lock> ( -- lock )
55 <dlist> <dlist> 0 f rw-lock boa ;
59 : add-reader ( lock -- )
60 [ 1 + ] change-reader# drop ;
62 : acquire-read-lock ( lock timeout -- )
64 [ 2dup [ readers>> ] dip "read lock" wait ] when drop
67 : notify-writer ( lock -- )
70 : remove-reader ( lock -- )
71 [ 1 - ] change-reader# drop ;
73 : release-read-lock ( lock -- )
75 dup reader#>> zero? [ notify-writer ] [ drop ] if ;
77 : acquire-write-lock ( lock timeout -- )
78 over writer>> pick reader#>> 0 > or
79 [ 2dup [ writers>> ] dip "write lock" wait ] when drop
82 : release-write-lock ( lock -- )
84 dup readers>> deque-empty?
85 [ notify-writer ] [ readers>> notify-all ] if ;
87 : reentrant-read-lock-ok? ( lock -- ? )
88 #! If we already have a write lock, then we can grab a read
92 : reentrant-write-lock-ok? ( lock -- ? )
93 #! The only case where we have a writer and > 1 reader is
94 #! write -> read re-entrancy, and in this case we prohibit
95 #! a further write -> read -> write re-entrancy.
96 { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
100 : with-read-lock-timeout ( lock timeout quot -- )
101 pick reentrant-read-lock-ok? [
102 [ drop add-reader ] [ remove-reader ] do-lock
104 [ acquire-read-lock ] [ release-read-lock ] do-lock
107 : with-read-lock ( lock quot -- )
108 f swap with-read-lock-timeout ; inline
110 : with-write-lock-timeout ( lock timeout quot -- )
111 pick reentrant-write-lock-ok? [ 2nip call ] [
112 [ acquire-write-lock ] [ release-write-lock ] do-lock
115 : with-write-lock ( lock quot -- )
116 f swap with-write-lock-timeout ; inline