1 ! Copyright (C) 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: dequeues dlists kernel threads continuations math
\r
4 concurrency.conditions ;
\r
5 IN: concurrency.locks
\r
7 ! Simple critical sections
\r
8 TUPLE: lock threads owner reentrant? ;
\r
10 : <lock> ( -- lock )
\r
11 <dlist> f f lock boa ;
\r
13 : <reentrant-lock> ( -- lock )
\r
14 <dlist> f t lock boa ;
\r
18 : acquire-lock ( lock timeout -- )
\r
20 [ 2dup >r lock-threads r> "lock" wait ] when drop
\r
21 self swap set-lock-owner ;
\r
23 : release-lock ( lock -- )
\r
24 f over set-lock-owner
\r
25 lock-threads notify-1 ;
\r
27 : do-lock ( lock timeout quot acquire release -- )
\r
28 >r >r pick rot r> call ! use up timeout acquire
\r
29 swap r> curry [ ] cleanup ; inline
\r
31 : (with-lock) ( lock timeout quot -- )
\r
32 [ acquire-lock ] [ release-lock ] do-lock ; inline
\r
36 : with-lock-timeout ( lock timeout quot -- )
\r
37 pick lock-reentrant? [
\r
38 pick lock-owner self eq? [
\r
47 : with-lock ( lock quot -- )
\r
48 f swap with-lock-timeout ; inline
\r
50 ! Many-reader/single-writer locks
\r
51 TUPLE: rw-lock readers writers reader# writer ;
\r
53 : <rw-lock> ( -- lock )
\r
54 <dlist> <dlist> 0 f rw-lock boa ;
\r
58 : add-reader ( lock -- )
\r
59 dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
\r
61 : acquire-read-lock ( lock timeout -- )
\r
63 [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
\r
66 : notify-writer ( lock -- )
\r
67 rw-lock-writers notify-1 ;
\r
69 : remove-reader ( lock -- )
\r
70 dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
\r
72 : release-read-lock ( lock -- )
\r
74 dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
\r
76 : acquire-write-lock ( lock timeout -- )
\r
77 over rw-lock-writer pick rw-lock-reader# 0 > or
\r
78 [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
\r
79 self swap set-rw-lock-writer ;
\r
81 : release-write-lock ( lock -- )
\r
82 f over set-rw-lock-writer
\r
83 dup rw-lock-readers dequeue-empty?
\r
84 [ notify-writer ] [ rw-lock-readers notify-all ] if ;
\r
86 : reentrant-read-lock-ok? ( lock -- ? )
\r
87 #! If we already have a write lock, then we can grab a read
\r
89 rw-lock-writer self eq? ;
\r
91 : reentrant-write-lock-ok? ( lock -- ? )
\r
92 #! The only case where we have a writer and > 1 reader is
\r
93 #! write -> read re-entrancy, and in this case we prohibit
\r
94 #! a further write -> read -> write re-entrancy.
\r
95 dup rw-lock-writer self eq?
\r
96 swap rw-lock-reader# zero? and ;
\r
100 : with-read-lock-timeout ( lock timeout quot -- )
\r
101 pick reentrant-read-lock-ok? [
\r
102 [ drop add-reader ] [ remove-reader ] do-lock
\r
104 [ acquire-read-lock ] [ release-read-lock ] do-lock
\r
107 : with-read-lock ( lock quot -- )
\r
108 f swap with-read-lock-timeout ; inline
\r
110 : with-write-lock-timeout ( lock timeout quot -- )
\r
111 pick reentrant-write-lock-ok? [ 2nip call ] [
\r
112 [ acquire-write-lock ] [ release-write-lock ] do-lock
\r
115 : with-write-lock ( lock quot -- )
\r
116 f swap with-write-lock-timeout ; inline
\r